--::::::::::
--sintf.spc
--::::::::::
with String_Pkg;
with String_Lists;
with Integer_Lists;
with Lists;
with Paginated_Output;
package Standard_Interface is --| Standard interface package
--| Overview
--| This package is used to:
--|-
--| 1. parse a line of arguments expressed in Ada (valid Ada is accepted but
--| may not be required depending on the set of switches defined below)
--| 2. create a paginated output file with a standardized header and/or footer
--| text(s) and page size
--|+
--| Given a specification of the arguments to be parsed, the subprogram
--| Parse_Line parses a given line. If there were errors, they are reported*
--| on the current output and a description* of valid input is given and
--| Abort_Process exception is raised. If there are no errors, the process
--| and argument(s) are echoed* to current output using named parameter
--| associations, showing the values of every parameter, even those that were
--| defaulted. A prompt* is given to continue with the process or to abort by
--| raising Abort_Process exception.
--|-
--| * : These operations are controlled by switches
--|+
--| If Parse_Line is successful (returns TRUE), a subprogram Get_Argument may
--| be called to obtain the value of an argument by its named association.
--| Six types of arguments are supported :
--| integer, string, enumeration, list of integers, list of strings, and list
--| of enumeration values.
--|
--| Generic package Command_Line is provided for parsing an enumerated set
--| of commands and their corresponding arguments.
--|
--| Generic packages Enumerated_Argument, Emunerated_List_Argument,
--| Integer_Argument, Integer_List_Argument, and String_List_Argument
--| are provided for arguments which are enumeration type, list of enumeration
--| type, integer subtype (ie. range), list of integer subtype, and list of
--| string type, respectively. These package must be instantiated with proper
--| types to obtain the appropriate subprograms for a given type.
--|
--| The subprogram Define_Output returns a paginated file handle to be used for
--| subsequent output operations, or will create a paginated output file and
--| set the current paginated output file to be the specified file.
--|
--|
--| The syntax of a process is specified by providing the following information:
--|-
--| 1. Name of the process
--| 2. General help pertaining to this process (optional)
--| 3. For each argument
--| a. Name - a string
--| b. Help - a string (optional)
--| c. Default value - type of argument being defined (optional)
--| 4. Any other text to appear in the help message (optional)
--|+
pragma page;
--| Notes:
--|-
--| The format of the standard header is :
--|
--| +------------------------- // -------------------------+
--| | (intentionally left blank) |
--| +------------------------- // -------------------------+
--| | Standard Header (ie. Name, Date, Time, Page) |
--| +------------------------- // -------------------------+
--| | User Defined Non-standard Header 1 |
--| +------------------------- // -------------------------+
--| | |
--| - -
--| | |
--| +------------------------- // -------------------------+
--| | User Defined Non-standard Header n |
--| +------------------------- // -------------------------+
--| | (intentionally left blank) |
--| +------------------------- // -------------------------+
--| | (First line of text) |
--| | |
--|
--| where n may be 0 to 9
--|+
--| Goals
--|- 1. It should be easy to write the definition of a command line
--| 2. It should be easy for the user to type commands
--| 3. It should accept valid Ada (but not require it)
--| 4. Handle ALL aspects of parsing, reporting errors, etc.
--| 5. Use not limited to command line parsing
--|+
pragma page;
----------------------------------------------------------------
package SL renames String_Lists;
package SP renames String_Pkg;
package IL renames Integer_Lists;
package PO renames Paginated_Output;
----------------------------------------------------------------
type Process_Handle is limited private;
--| Holds all command and parameter information
subtype Size is INTEGER range 0 .. 9;
--| Non standard header size
subtype Number is INTEGER range 1 .. Size'last;
--| Non standard header number
type Switch is (ON, OFF);
--| Switch (boolean) variable
type Parsing_Checks is ( --| Parsing switches
Ending_Delimiter,
Argument_Enclosure,
Quote_Enclosure );
type Action_Checks is ( --| Action switches
Show_Help,
Show_Error,
Show_Help_on_Error,
Echo_Command,
Prompt_for_Reply );
type Command_Checks is ( --| Command action switches
Show_Help,
Show_Error,
Show_Help_on_Null,
Show_Help_on_Error);
----------------------- Parsing Switches -----------------------------------
Parsing_Switches : array (Parsing_Checks) of Switch :=
--| The elements of the Parsing_Switches may be changed to control
--| parsing actions. Setting these switches OFF will relax parsing
--| stipulations but may result in ambiguities.
(Ending_Delimiter => ON, --| Check for ending delimiter
Argument_Enclosure => ON, --| Check for enclosing charactrers
Quote_Enclosure => ON); --| Check strings enclosing quotes
----------------------- Action Switches ------------------------------------
Action_Switches : array (Action_Checks) of Switch :=
--| The elements of the Action_Switches may be changed to control
--| actions taken by the standard interface.
(Show_Help => ON, --| Display help message if no argument(s)
Show_Error => ON, --| Display message on detecting error(s)
Show_Help_on_Error => ON, --| Display Help message on error(s)
Echo_Command => ON, --| Echo arguments
Prompt_for_Reply => OFF); --| Prompt to continue/abort
----------------------- Command Switches -----------------------------------
Command_Switches : array (Command_Checks) of Switch :=
--| The elements of the Command_Switches may be changed to control
--| actions taken by the standard interface command parser.
(Show_Help => ON, --| Display command help message
Show_Error => ON, --| Display message on detecting error(s)
Show_Help_on_Null => OFF, --| Display help when no command is entered
Show_Help_on_Error => OFF); --| Display help message on command error
----------------------- Parsing Strings ------------------------------------
Delimiter : SP.String_Type := --| Argument seperator
SP.Make_Persistent(",");
--| Delimiter string defines a set of characters that are recognized as
--| argument delimiters.
--| To change the delimiter characters
--| SP.Flush(Delimiter); -- free storage
--| Delimiter := SP.Make_Persistent("|/"); -- | and / as a delimiters
--| The default delimiter character is ","
Assignment : SP.String_Type := --| Assignment string
SP.Make_Persistent("=>");
--| Assignment string defines a string that is recognized as an assigment
--| indicator. To change the assigment string follow procedures shown
--| for changing delimiter characters.
--| The default assignment string is "=>"
Left_Enclosure : CHARACTER := '('; --| Argument/list left enclosure
Right_Enclosure : CHARACTER := ')'; --| Argument/list right enclosure
End_Delimiter : CHARACTER := ';'; --| Ending delimiter
--| Left_Enclosure, Right_Enclosure, and End_Delimiter may be changed by
--| simple character assigment. The defaults are "(", ")", and ";" respectively
----------------------------------------------------------------
Duplicate_Name : exception; --| Raised if an attempt is made to define
--| an existing argument
Invalid_Name : exception; --| Raised if the specified name (prcoess or
--| argument) is not an Ada identifier
Undefined_Name : exception; --| Raised if attempt is made to obtain the
--| value of an argument that was not defined
Uninitialized : exception; --| Raised if operation is attempted with an
--| uninitialized handle
Already_Exists : exception; --| Raised if a handle to be assigned is
--| already initialized
Invalid_Kind : exception; --| Raised if information sought is not
--| pertinent to the named argument
Not_Yet_Parsed : exception; --| Raised if information is sought before
--| (command) line is parsed
Already_Parsed : exception; --| Raised if attempt is made to define an
--| object after (command) line is parsed
Invalid_Type : exception; --| Raised if the integer subtype instantiation
--| is invalid
Abort_Process : exception; --| Raised if error(s) is detected or abort is
--| requested (via reply to a prompt)
Process_Help : exception; --| Raised if the Help message is printed
--| (by other than error conditions)
No_Default : exception; --| Raised if a request is made for a default
--| value where non was defined
Abort_Command : exception; --| Raised if command error(s) is detected
Command_Help : exception; --| Raised if the predefined HELP command is
--| entered
Command_Exit : exception; --| Raised if the predefined EXIT command is
--| entered
No_Command : exception; --| Raised if no command is entered
Identifier_Error : exception; --| Tool identifier has not been set or
--| set more than once
Internal_Error : exception; --| Raised for internal errors
pragma page;
----------------------------------------------------------------
procedure Set_Tool_Identifier( --| Set identifier
Identifier : in STRING --| Identifier string
);
--| Raises: Identifier_Error
--| Effects:
--| Sets the tool identifier to be displayed in the help message.
----------------------------------------------------------------
function Get_Tool_Identifier --| Get identifier
return STRING;
--| Raises: Identifier_Error
--| Effects:
--| Gets the tool identifier.
----------------------------------------------------------------
procedure Define_Process( --| Define a process
Name : in STRING; --| Process name
Help : in STRING; --| Explanation of process
Proc : in out Process_Handle --| Process handle
);
--| Raises: Already_Exists, Invalid_Name, Already_Parsed, Identifier_Error
--| Effects:
--| Defines the name of the process for use in displaying help or echoing
--| the actual parameters. Return value is the internal representation
--| of the process definition.
----------------------------------------------------------------
procedure Redefine_Process( --| Redefine a process
Proc : in Process_Handle --| Process handle
);
--| Raises: Uninitialized
--| Effects:
--| Re-defines the process after parsing so that another line may be parsed
--| using the same process handle
----------------------------------------------------------------
procedure Undefine_Process( --| Delete process structure
Proc : in out Process_Handle --| Process handle
);
--| Effects:
--| Deletes the process and its associated argument definitions and frees
--| storage used.
----------------------------------------------------------------
procedure Define_Process_Name( --| Provide general help
Proc : in Process_Handle; --| Process being defined
Name : in STRING --| Process name
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Override current process name in the internal process representatio
----------------------------------------------------------------
procedure Define_Process_Help( --| Provide general help
Proc : in Process_Handle; --| Process being defined
Help : in STRING
);
--| Raises: Uninitialized, Already_Parsed
--| Effects:
--| Define Help message internally stored for output if errors are
--| detected.
----------------------------------------------------------------
procedure Append_Process_Help( --| Provide general help
Proc : in Process_Handle; --| Process being defined
Help : in STRING
);
--| Raises: Uninitialized, Already_Parsed
--| Effects:
--| Appends to the Help message internally stored
----------------------------------------------------------------
procedure Define_Help( --| Provide general help
Proc : in Process_Handle; --| Process being defined
Help : in STRING
);
--| Raises: Uninitialized, Already_Parsed
--| Effects:
--| Define general Help message for output in the help message
----------------------------------------------------------------
procedure Append_Help( --| Provide general help
Proc : in Process_Handle; --| Process being defined
Help : in STRING
);
--| Raises: Uninitialized, Already_Parsed
--| Effects:
--| Appends to the general Help message internally stored.
----------------------------------------------------------------
procedure Parse_Line( --| Parse the command line arguments
Proc : in Process_Handle --| Porcess defined
);
--| Raises: Uninitialized, Already_Parsed, Abort_Process, Process_Help
--| Effects:
--| Parse the commmand line according the process specification given by the
--| process handle.
--| Error message, help message, echoing, and/or prompt depends on the switches.
--| If any errors are detected (regardless of the above switches) Abort_Process
--| exception will be raised.
--|
--| Errors
--| The following errors are detected:
--|-
--| 1. Invalid command line syntax (eg. missing semicolon)
--| 2. Wrong type of argument supplied
--| 3. Required argument missing
--| 3. Value not in range (for integer and enumeration types)
--|+
----------------------------------------------------------------
procedure Parse_Line( --| Parse the line arguments
Proc : in Process_Handle; --| Process being defined
Line : in STRING --| Parameters to be parsed
);
--| Raises: Uninitialized, Already_Parsed, Abort_Process, Process_Help
--| Effects:
--| Parse the given line according the process specification given by the
--| process handle.
--| Error message, help message, echoing, and/or prompt depends on the switches.
--| If any errors are detected (regardless of the above switches) Abort_Process
--| exception will be raised.
--|
--| Errors
--| The following errors are detected:
--|-
--| 1. Invalid line syntax (eg. missing semicolon)
--| 2. Wrong type of argument supplied
--| 3. Required argument missing
--| 3. Value not in range (for integer and enumeration types)
--|+
----------------------------------------------------------------
procedure Show_Help(
Proc : in Process_Handle
);
--| Raises: Uninitialized
--| Effects:
--| Outputs the general Help message.
----------------------------------------------------------------
procedure Echo_Process(
Proc : in Process_Handle
);
--| Raises: Uninitialized, Not_Yet_Parsed
--| Effects:
--| Outputs the "echo" of the process arguments.
----------------------------------------------------------------
function Continue(
Proc : in Process_Handle
) return BOOLEAN;
--| Raises: Uninitialized, Not_Yet_Parsed
--| Effects:
--| Prompts for a reply to continue or abort.
--| Returns TRUE if the reply was to continue, FALSE otherwise.
----------------------------------------------------------------
procedure Define_Output( --| Define paginated output
Proc : in Process_Handle; --| Process handle
File_Name : in STRING; --| File name
Header_Size : in Size := 0; --| Size of the user defined header
Paginate : in BOOLEAN := TRUE --| Pagination switch
);
--| Raises: Paginated_Output.File_Already_Open, Paginated_Output.File_Error,
--| Paginated_Output.Page_Layout_Error;
--| Effects:
--| Create a paginated output file with File_Name and set paginated standard
--| output to this file
----------------------------------------------------------------
procedure Define_Output( --| Define paginated output
Proc : in Process_Handle;--| Process handle
File_Name : in STRING; --| File name
Header_Size : in Size := 0; --| Size of the user defined header
File_Handle : in out PO.Paginated_File_Handle;
--| Handle to paginated file
Paginate : in BOOLEAN := TRUE--| Pagination switch
);
--| Raises: Paginated_Output.File_Already_Open, Paginated_Output.File_Error,
--| Paginated_Output.Page_Layout_Error;
--| Effects:
--| Create a paginated output file with File_Name and return a handle
----------------------------------------------------------------
procedure Define_Header( --| Define non standard header
Line : in Number; --| Line number of the header
Text : in STRING --| Header text
);
--| Raises: Paginated_Output.Invalid_File, Paginated_Output.Text_Overflow,
--| Effects:
--| Defines the Line'th line of the non standard header.
----------------------------------------------------------------
procedure Define_Header( --| Define non standard header
File_Handle : in PO.Paginated_File_Handle;
--| Handle to paginated file
Line : in Number; --| Line number of the header
Text : in STRING --| Header text
);
--| Raises: Paginated_Output.Invalid_File, Paginated_Output.Text_Overflow,
--| Effects:
--| Defines the Line'th line of the non standard header.
----------------------------------------------------------------
pragma page;
generic
type Enum_Type is (<>);
Enum_Type_Name : STRING;
package Enumerated_Argument is
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Default : in Enum_Type; --| Default value
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Store Help message for the argument
----------------------------------------------------------------
procedure Append_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Undefined_Name, Already_Parsed
--| Effects:
--| Append to the Help message associated with the argument.
----------------------------------------------------------------
function Get_Argument( --| Return the specified argument
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return Enum_Type;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind
--| Effects:
--| Return an argument value from the argument called Name on the command
--| line (or the default value if no value was supplied).
----------------------------------------------------------------
function Get_Default( --| Return the default for specified
--| argument if one exists
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return Enum_Type;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
--| No_Default
--| Effects:
--| Return the default value from the argument called Name
--| An exception is raised if no default was defined for the argument.
----------------------------------------------------------------
function Defaulted( --| Return defaulted/specified status
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return BOOLEAN;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed
--| Effects:
--| Return a boolean indication TRUE if the value is defaulted
--| FALSE if specified
----------------------------------------------------------------
end Enumerated_Argument;
pragma page;
generic
type Enum_Type is (<>);
Enum_Type_Name : STRING;
Enum_Type_List : STRING;
package Enumerated_List_Argument is
package Enumerated_Lists is new Lists(Enum_Type);
package EL renames Enumerated_Lists;
type Enum_Type_Array is array (POSITIVE range <>) of Enum_Type;
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Default : in Enum_Type_Array; --| Default value
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Store Help message for the argument
----------------------------------------------------------------
procedure Append_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Undefined_Name, Already_Parsed
--| Effects:
--| Append to the Help message associated with the argument.
----------------------------------------------------------------
function Get_Argument( --| Return the specified argument
Proc : in Process_Handle; --| Definition of the command
Name : in STRING --| Name of the desired argument
) return EL.List;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind
--| Effects:
--| Return an argument value from the argument called Name on the command
--| line (or the default value if no value was supplied).
----------------------------------------------------------------
function Get_Default( --| Return the default for specified
--| argument if one exists
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return EL.List;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
--| No_Default
--| Effects:
--| Return the default value from the argument called Name
--| An exception is raised if no default was defined for the argument.
----------------------------------------------------------------
function Defaulted( --| Return defaulted/specified status
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return BOOLEAN;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed
--| Effects:
--| Return a boolean indication TRUE if the value is defaulted
--| FALSE if specified
----------------------------------------------------------------
end Enumerated_List_Argument;
pragma page;
generic
type Integer_Type is range <>;
Integer_Type_Name : STRING;
package Integer_Argument is
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Default : in Integer_Type; --| Default value
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Store Help message for the argument
----------------------------------------------------------------
procedure Append_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Undefined_Name, Already_Parsed
--| Effects:
--| Append to the Help message associated with the argument.
----------------------------------------------------------------
function Get_Argument( --| Return the specified argument
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return Integer_Type;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind
--| Effects:
--| Return an argument value from the argument called Name on the command
--| line (or the default value if no value was supplied).
----------------------------------------------------------------
function Get_Default( --| Return the default for specified
--| argument if one exists
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return Integer_Type;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
--| No_Default
--| Effects:
--| Return the default value from the argument called Name
--| An exception is raised if no default was defined for the argument.
----------------------------------------------------------------
function Defaulted( --| Return defaulted/specified status
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return BOOLEAN;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed
--| Effects:
--| Return a boolean indication TRUE if the value is defaulted
--| FALSE if specified
----------------------------------------------------------------
end Integer_Argument;
pragma page;
generic
type Integer_Type is range <>;
Integer_Type_Name : STRING;
Integer_Type_List : STRING;
package Integer_List_Argument is
type Integer_Type_Array is array (POSITIVE range <>) of Integer_Type;
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Default : in Integer_Type_Array;--| Default value
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Store Help message for the argument
----------------------------------------------------------------
procedure Append_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Undefined_Name, Already_Parsed
--| Effects:
--| Append to the Help message associated with the argument.
----------------------------------------------------------------
function Get_Argument( --| Return the specified argument
Proc : in Process_Handle; --| Definition of the command
Name : in STRING --| Name of the desired argument
) return IL.List;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind
--| Effects:
--| Return an argument value from the argument called Name on the command
--| line (or the default value if no value was supplied).
----------------------------------------------------------------
function Get_Default( --| Return the default for specified
--| argument if one exists
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return IL.List;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
--| No_Default
--| Effects:
--| Return the default value from the argument called Name
--| An exception is raised if no default was defined for the argument.
----------------------------------------------------------------
function Defaulted( --| Return defaulted/specified status
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return BOOLEAN;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed
--| Effects:
--| Return a boolean indication TRUE if the value is defaulted
--| FALSE if specified
----------------------------------------------------------------
end Integer_List_Argument;
pragma page;
generic
String_Type_Name : STRING;
package String_Argument is
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Default : in STRING; --| Default value
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Store Help message for the argument
----------------------------------------------------------------
procedure Append_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Undefined_Name, Already_Parsed
--| Effects:
--| Append to the Help message associated with the argument.
----------------------------------------------------------------
function Get_Argument( --| Return the specified argument
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return SP.String_Type;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind
--| Effects:
--| Return an argument value from the argument called Name on the command
--| line (or the default value if no value was supplied).
----------------------------------------------------------------
function Get_Default( --| Return the default for specified
--| argument if one exists
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return SP.String_Type;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
--| No_Default
--| Effects:
--| Return the default value from the argument called Name
--| An exception is raised if no default was defined for the argument.
----------------------------------------------------------------
function Defaulted( --| Return defaulted/specified status
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return BOOLEAN;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed
--| Effects:
--| Return a boolean indication TRUE if the value is defaulted
--| FALSE if specified
----------------------------------------------------------------
end String_Argument;
pragma page;
generic
String_Type_Name : STRING;
String_Type_List : STRING;
package String_List_Argument is
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument( --| Define an input argument
Proc : in Process_Handle; --| Process being defined
Name : in STRING; --| Name of the argument
Default : in SL.List; --| Default value
Help : in STRING --| Explanation of the argument
);
--| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Each time this procedure is called, it defines a new
--| process argument; the first call defines the first argument,
--| the second the second argument, etc. Exceptions are raised if
--| a duplicate name is defined.
----------------------------------------------------------------
procedure Define_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Invalid_Name, Already_Parsed
--| Effects:
--| Store Help message for the argument
----------------------------------------------------------------
procedure Append_Argument_Help( --| Provide general help
Proc : in Process_Handle; --| Process handle
Name : in STRING; --| Argument being defined
Help : in STRING --| Help string
);
--| Raises: Uninitialized, Undefined_Name, Already_Parsed
--| Effects:
--| Append to the Help message associated with the argument.
----------------------------------------------------------------
function Get_Argument( --| Return the specified argument
Proc : in Process_Handle; --| Definition of the command
Name : in STRING --| Name of the desired argument
) return SL.List;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind
--| Effects:
--| Return an argument value from the argument called Name on the command
--| line (or the default value if no value was supplied).
----------------------------------------------------------------
function Get_Default( --| Return the default for specified
--| argument if one exists
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return SL.List;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
--| No_Default
--| Effects:
--| Return the default value from the argument called Name
--| An exception is raised if no default was defined for the argument.
----------------------------------------------------------------
function Defaulted( --| Return defaulted/specified status
Proc : in Process_Handle; --| Definition of the process
Name : in STRING --| Name of the desired argument
) return BOOLEAN;
--| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed
--| Effects:
--| Return a boolean indication TRUE if the value is defaulted
--| FALSE if specified
----------------------------------------------------------------
end String_List_Argument;
pragma page;
generic
type Command_Enumeration is (<>);
package Command_Line is
type Process_Handle_Array is array (Command_Enumeration) of Process_Handle;
----------------------------------------------------------------
function Parse_Command_Line( --| Parse a line including command
Handles : in Process_Handle_Array;
--| Array of process handles
Line : in STRING --| Line to be parsed
) return Command_Enumeration;
--| Raises: Undefined_Command, Uninitialized, Already_Parsed,
--| Abort_Process, Process_Help
--| Effects:
--| First parse the line for valid command and if found parse the arguments
--| according to the specification given by the corresponding process
--| handle (See Parse_Line for details of argument parsing).
--| If parsing is successful returns an enumeration type of the command
----------------------------------------------------------------
end Command_Line;
pragma page;
private
pragma List(off);
type Argument_Kind is (INT, INT_LIST, STR, STR_LIST, ENUM, ENUM_LIST);
-- Kinds of argument
type Argument_Record is
record
name : SP.String_Type; -- Specifies the name of an argument
typename : SP.String_Type; -- Argument type name
listname : SP.String_Type; -- Argument list type name
kind : Argument_Kind; -- Specifies the argument type
help : SL.List := SL.Create;-- Help message for this argument
default : SL.List := SL.Create;-- Specifies a default value
value : SL.List := SL.Create;-- Argument value
required : BOOLEAN; -- Required argument switch
supplied : BOOLEAN := FALSE; -- Argument supplied switch
low : INTEGER; -- Integer type range low
high : INTEGER; -- Integer type range high
valid : SL.List := SL.Create;-- Valid Enum_Type
end record;
type Argument_Handle is access Argument_Record;
package AL is new Lists(Argument_Handle);
type Process_Record is
record
parsed : BOOLEAN := FALSE;
name : SP.String_Type := SP.Make_Persistent("");
help : SL.List := SL.Create;
args : AL.List := AL.Create;
msgs : SL.List := SL.Create;
maxname : NATURAL := 0;
maxtypename : NATURAL := 0;
maxtype : NATURAL := 0;
typecolumn : POSITIVE := 6;
end record;
type Process_Handle is access Process_Record;
pragma List(on);
end Standard_Interface;
pragma page;
--::::::::::
--sintf.bdy
--::::::::::
with String_Utilities;
with Unchecked_Deallocation;
with Host_Lib;
with Text_IO;
package body Standard_Interface is
----------------------------------------------------------------
package HL renames Host_Lib;
package SU renames String_Utilities;
package SS is new SU.Generic_String_Utilities(SP.String_Type,
SP.Make_Persistent,
SP.Value);
----------------------------------------------------------------
type Token_Kind is (NAME, BIND, LIST, QUOTED, VALUE, DONE, NONE);
type Process_Status is (CLEAN, ERROR, SEVERE);
type Error_Types is (Missing_End_Delimiter,
Missing_Argument_Enclosure,
Missing_Quotes,
Non_Ada_Name,
Name_Not_Defined,
Missing_Name,
Missing_Argument,
Missing_Required_Argument,
Missing_Named_Value,
Invalid_Value,
Invalid_List,
Too_Many_Arguments,
Positional_After_Named,
Invalid_Command);
type Error_Action is (CONTINUE, STOP);
type Error_Record is
record
msg : SP.String_Type;
flag : Error_Action;
end record;
----------------------------------------------------------------
Status : Process_Status;
Short_Help : BOOLEAN := FALSE;
Set_ID : BOOLEAN := FALSE;
ID : SP.String_Type;
--------------------- Error Messages ---------------------------
-- Substitutions are made for
-- ~A : Name of the argument as defined
-- ~N : Name of the argument as entered
-- ~V : Value of the argument as entered
Errors : constant array (Error_Types) of Error_Record :=
(Missing_End_Delimiter =>
(SP.Make_Persistent("Missing an ending delimiter ~A"),
CONTINUE),
Missing_Argument_Enclosure =>
(SP.Make_Persistent("Arguments not enclosed in ~A"),
CONTINUE),
Missing_Quotes =>
(SP.Make_Persistent("String value ~V not enclosed in quotes"),
CONTINUE),
Non_Ada_Name =>
(SP.Make_Persistent("Specified name ~N is not a valid identifier"),
CONTINUE),
Name_Not_Defined =>
(SP.Make_Persistent("Specified name ~N is not defined"),
CONTINUE),
Missing_Name =>
(SP.Make_Persistent("Name not specified"),
CONTINUE),
Missing_Argument =>
(SP.Make_Persistent("Argument not specified"),
CONTINUE),
Missing_Required_Argument =>
(SP.Make_Persistent("Required argument ~A not specified"),
CONTINUE),
Missing_Named_Value =>
(SP.Make_Persistent("Named value ~N not specified"),
CONTINUE),
Invalid_Value =>
(SP.Make_Persistent("Specified argument ~V not valid"),
CONTINUE),
Invalid_List =>
(SP.Make_Persistent("List specification ~V not valid"),
CONTINUE),
Too_Many_Arguments =>
(SP.Make_Persistent("Too many arguments specified"),
CONTINUE),
Positional_After_Named =>
(SP.Make_Persistent("A positional association must not occur after a named association"),
STOP),
Invalid_Command =>
(SP.Make_Persistent("Command ~V not defined"),
STOP));
-------------------- Common File Header -------------------------
-- The header is prepended by name of the process as defined
-- by Define_Process
File_Header : constant SP.String_Type :=
SP.Make_Persistent("~D ~T Page ~P(R3)");
pragma Page;
---------------- Local Subprogam Specifications ----------------
procedure Free_Process_Structure is
new Unchecked_Deallocation(Process_Record, Process_Handle);
----------------------------------------------------------------
procedure Free_Argument_Structure is
new Unchecked_Deallocation(Argument_Record, Argument_Handle);
----------------------------------------------------------------
function Release return STRING;
----------------------------------------------------------------
procedure Check_ID;
----------------------------------------------------------------
procedure Check_Uninitialized(
Proc : in Process_Handle
);
----------------------------------------------------------------
procedure Check_Already_Exists(
Proc : in Process_Handle
);
----------------------------------------------------------------
procedure Check_Invalid_Name(
Name : in STRING
);
----------------------------------------------------------------
procedure Check_Undefined_Name(
Proc : in Process_Handle;
Name : in STRING
);
----------------------------------------------------------------
procedure Check_Duplicate_Name(
Proc : in Process_Handle;
Name : in STRING
);
----------------------------------------------------------------
procedure Check_Not_Yet_Parsed(
Proc : in Process_Handle
);
----------------------------------------------------------------
procedure Check_Already_Parsed(
Proc : in Process_Handle
);
----------------------------------------------------------------
procedure Check_Invalid_Kind(
Proc : in Process_Handle;
Name : in STRING;
Kind : in Argument_Kind
);
----------------------------------------------------------------
procedure Write(
Text : in STRING
);
----------------------------------------------------------------
procedure New_Line(
Count : in POSITIVE
);
----------------------------------------------------------------
procedure Write_List_Vertical(
Header : in STRING;
List : in SL.List
);
----------------------------------------------------------------
procedure Write_List_Horizontal(
List : in SL.List;
Quoted : in BOOLEAN := FALSE
);
----------------------------------------------------------------
function Find_Match(
Proc : in Process_Handle;
Name : in STRING
) return Argument_Handle;
----------------------------------------------------------------
function Get_Argument_Handle(
Proc : in Process_Handle;
Name : in STRING
) return Argument_Handle;
----------------------------------------------------------------
procedure Destroy_String_List is new SL.DestroyDeep(Dispose => SP.Flush);
----------------------------------------------------------------
procedure Destroy_Argument_Help(
Proc : in Process_Handle;
Name : in STRING
);
----------------------------------------------------------------
procedure Set_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
);
----------------------------------------------------------------
function Set_Argument(
Proc : in Process_Handle;
Name : in STRING;
Kind : in Argument_Kind;
Typename : in STRING;
Listname : in STRING;
Required : in BOOLEAN
) return Argument_Handle;
----------------------------------------------------------------
procedure Point_Next_Token(
Scanner : in SU.Scanner
);
----------------------------------------------------------------
procedure Get_Next_Token(
Scanner : in SU.Scanner;
Kind : out Token_Kind;
Token : in out SP.String_Type
);
----------------------------------------------------------------
procedure Parse_Argument(
Argument : in Argument_Handle;
Item : in SP.String_Type;
Kind : in Token_Kind
);
----------------------------------------------------------------
procedure Report_Error(
Kind : in Error_Types;
Argument : in STRING := "";
Name : in STRING := "";
Value : in STRING := ""
);
----------------------------------------------------------------
pragma Page;
---------------------- Visible Subprogams ----------------------
procedure Set_Tool_Identifier(
Identifier : in STRING
) is
begin
Check_ID;
raise Identifier_Error;
exception
when Identifier_Error =>
Set_ID := TRUE;
ID := SP.Make_Persistent(Identifier);
end Set_Tool_Identifier;
----------------------------------------------------------------
function Get_Tool_Identifier
return STRING is
begin
Check_ID;
return Release & '-' & SP.Value(ID);
end Get_Tool_Identifier;
----------------------------------------------------------------
procedure Define_Process(
Name : in STRING;
Help : in STRING;
Proc : in out Process_Handle
) is
begin
Check_ID;
Check_Invalid_Name(Name);
Check_Already_Exists(Proc);
Proc := new Process_Record;
Define_Process_Name(Proc, Name);
Define_Process_Help(Proc, Help);
end Define_Process;
----------------------------------------------------------------
procedure Redefine_Process(
Proc : in Process_Handle
) is
Iterator : AL.ListIter;
Item : Argument_Handle;
begin
Check_Not_Yet_Parsed(Proc);
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) loop
AL.Next(Iterator, Item);
if Item.supplied then
Item.supplied := FALSE;
Destroy_String_List(Item.value);
Item.value := SL.Create;
end if;
end loop;
Proc.parsed := FALSE;
exception
when Not_Yet_Parsed =>
null;
end Redefine_Process;
----------------------------------------------------------------
procedure Undefine_Process(
Proc : in out Process_Handle
) is
Iterator : AL.ListIter;
Item : Argument_Handle;
begin
if Proc /= null then
SP.Flush(Proc.name);
Destroy_String_List(Proc.help);
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) loop
AL.Next(Iterator, Item);
SP.Flush(Item.name);
SP.Flush(Item.typename);
SP.Flush(Item.listname);
Destroy_String_List(Item.help);
Destroy_String_List(Item.default);
Destroy_String_List(Item.value);
Free_Argument_Structure(Item);
end loop;
AL.Destroy(Proc.args);
Destroy_String_List(Proc.msgs);
end if;
Free_Process_Structure(Proc);
end Undefine_Process;
----------------------------------------------------------------
procedure Define_Process_Name(
Proc : in Process_Handle;
Name : in STRING
) is
begin
Check_Invalid_Name(Name);
Check_Already_Parsed(Proc);
SP.Flush(Proc.name);
Proc.name := SP.Make_Persistent(SP.Upper(Name));
end Define_Process_Name;
----------------------------------------------------------------
procedure Define_Process_Help(
Proc : in Process_Handle;
Help : in STRING
) is
begin
Check_Already_Parsed(Proc);
Destroy_String_List(Proc.help);
Proc.help := SL.Create;
Append_Process_Help(Proc, Help);
end Define_Process_Help;
----------------------------------------------------------------
procedure Append_Process_Help(
Proc : in Process_Handle;
Help : in STRING
) is
begin
Check_Already_Parsed(Proc);
SL.Attach(Proc.help, SP.Make_Persistent(Help));
end Append_Process_Help;
----------------------------------------------------------------
procedure Define_Help(
Proc : in Process_Handle;
Help : in STRING
) is
begin
Check_Already_Parsed(Proc);
Destroy_String_List(Proc.msgs);
Proc.msgs := SL.Create;
Append_Help(Proc, Help);
end Define_Help;
----------------------------------------------------------------
procedure Append_Help(
Proc : in Process_Handle;
Help : in STRING
) is
begin
Check_Already_Parsed(Proc);
SL.Attach(Proc.msgs, SP.Make_Persistent(Help));
end Append_Help;
----------------------------------------------------------------
procedure Parse_Line(
Proc : in Process_Handle;
Line : in STRING
) is
S_Str : SP.String_Type;
Current : Token_Kind;
Previous : Token_Kind := NONE;
Name_Val : SP.String_Type;
Named : BOOLEAN := FALSE;
Iterator : AL.ListIter;
Item : Argument_Handle;
Scanner : SU.Scanner;
Found : BOOLEAN;
begin
Check_Already_Parsed(Proc);
Status := CLEAN;
SP.Mark;
S_Str := SS.Strip(Line);
if SP.Length(S_Str) /= 0 then
if SP.Fetch(S_Str, SP.Length(S_Str)) = End_Delimiter then
S_Str := SS.Strip_Trailing(SP.Substr(S_Str, 1, SP.Length(S_Str) - 1));
elsif Parsing_Switches(Ending_Delimiter) = ON then
Report_Error(Missing_End_Delimiter,
Argument => "'" & End_Delimiter & "'");
end if;
elsif Parsing_Switches(Ending_Delimiter) = ON then
if Action_Switches(Show_Help) = ON then
Show_Help(Proc);
end if;
raise Process_Help;
end if;
Scanner := SS.Make_Scanner(S_Str);
SP.Release;
SU.Mark(Scanner);
if SU.More(Scanner) then
if SU.Is_Enclosed(Left_Enclosure, Right_Enclosure, Scanner) then
SS.Scan_Enclosed(Left_Enclosure, Right_Enclosure, Scanner, Found, S_Str);
if SU.More(Scanner) then
SU.Restore(Scanner);
if Parsing_Switches(Argument_Enclosure) = ON then
Report_Error(Missing_Argument_Enclosure,
Argument => "'" & Left_Enclosure & "' and '" & Right_Enclosure & "'");
end if;
else
SU.Destroy_Scanner(Scanner);
Scanner := SS.Make_Scanner(S_Str);
end if;
SP.Flush(S_Str);
elsif Parsing_Switches(Argument_Enclosure) = ON then
Report_Error(Missing_Argument_Enclosure,
Argument => "'" & Left_Enclosure & "' and '" & Right_Enclosure & "'");
end if;
end if;
SU.Skip_Space(Scanner);
S_Str := SS.Get_Remainder(Scanner);
SU.Destroy_Scanner(Scanner);
SP.Mark;
S_Str := SS.Strip(S_Str);
if SP.Length(S_Str) = 0 then
Scanner := SS.Make_Scanner(S_Str);
else
Scanner := SS.Make_Scanner(SP."&"(S_Str, "" & SP.Fetch(Delimiter, 1)));
end if;
SP.Flush(S_Str);
SP.Release;
Proc.parsed := TRUE;
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) and Previous /= DONE and Status /= SEVERE and not Named loop
AL.Next(Iterator, Item);
Get_Next_Token(Scanner, Current, S_Str);
case Current is
when NONE =>
Report_Error(Missing_Argument);
when DONE =>
null;
when NAME =>
Named := TRUE;
Name_Val := S_Str;
begin
Item := Get_Argument_Handle(Proc, SP.Value(Name_Val));
exception
when Invalid_Name =>
Report_Error(Non_Ada_Name,
Name => SP.Value(Name_Val));
when Undefined_Name =>
Report_Error(Name_Not_Defined,
Name => SP.Value(Name_Val));
end;
when BIND =>
Report_Error(Missing_Name);
when others =>
SP.Mark;
Parse_Argument(Item, S_Str, Current);
SP.Release;
end case;
Previous := Current;
end loop;
if Named then
while Previous /= DONE and Status /= SEVERE loop
Get_Next_Token(Scanner, Current, S_Str);
case Previous is
when NAME =>
null;
when BIND =>
case Current is
when NAME | NONE | DONE | BIND =>
Report_Error(Missing_Named_Value,
Name => SP.Value(Item.name));
if Current = BIND then
Report_Error(Missing_Name);
end if;
when others =>
SP.Mark;
Parse_Argument(Item, S_Str, Current);
SP.Release;
end case;
when others =>
case Current is
when DONE =>
null;
when NAME =>
Name_Val := S_Str;
begin
Item := Get_Argument_Handle(Proc, SP.Value(Name_Val));
exception
when Invalid_Name =>
Report_Error(Non_Ada_Name,
Name => SP.Value(Name_Val));
when Undefined_Name =>
Report_Error(Name_Not_Defined,
Name => SP.Value(Name_Val));
end;
when NONE =>
Report_Error(Missing_Argument);
when others =>
Report_Error(Positional_After_Named);
end case;
end case;
Previous := Current;
end loop;
else
Get_Next_Token(Scanner, Current, S_Str);
if Current /= DONE then
Report_Error(Too_Many_Arguments);
end if;
end if;
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) loop
AL.Next(Iterator, Item);
if Item.required and not Item.supplied then
Report_Error(Missing_Required_Argument, Argument=>SP.Value(Item.name));
end if;
end loop;
if Status = CLEAN then
if Action_Switches(Echo_Command) = ON then
Echo_Process(Proc);
end if;
if Action_Switches(Prompt_for_Reply) = ON then
if not Continue(Proc) then
Redefine_Process(Proc);
raise Abort_Process;
end if;
end if;
else
if Action_Switches(Show_Help_on_Error) = ON then
Show_Help(Proc);
end if;
Redefine_Process(Proc);
raise Abort_Process;
end if;
end Parse_Line;
----------------------------------------------------------------
procedure Parse_Line(
Proc : in Process_Handle
) is
begin
Parse_Line(Proc, HL.Get_Item(HL.ARGUMENTS, HL.EDIT));
end Parse_Line;
----------------------------------------------------------------
procedure Show_Help(
Proc : in Process_Handle
) is
IterA : AL.ListIter;
IterB : AL.ListIter;
Arg : Argument_Handle;
Argx : Argument_Handle;
First : BOOLEAN := TRUE;
S_Str : SP.String_Type;
Found : BOOLEAN;
begin
Check_Uninitialized(Proc);
SP.Mark;
HL.Set_Error;
if Short_Help then
Write_List_Vertical(SP.Value(Proc.name) & " : ", Proc.help);
SP.Release;
HL.Reset_Error;
return;
end if;
New_Line(1);
Write_List_Vertical(SP.Value(Proc.name) & " : ", Proc.help);
Write("-- " & Get_Tool_Identifier);
New_line(2);
IterA := AL.MakeListIter(Proc.args);
if AL.More(IterA) then
First := FALSE;
end if;
while AL.More(IterA) loop
AL.Next(IterA, Arg);
case Arg.kind is
when ENUM =>
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.typename, Argx.typename) then
Found := TRUE;
exit;
end if;
end loop;
if not Found and
not SP.Equal(Arg.typename, "BOOLEAN") and
not SP.Equal(Arg.typename, "CHARACTER") then
TEXT_IO.PUT("type");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
TEXT_IO.PUT(" is ");
TEXT_IO.PUT(Left_Enclosure);
Write_List_Horizontal(Arg.valid);
TEXT_IO.PUT(Right_Enclosure);
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
when ENUM_LIST =>
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.typename, Argx.typename) then
Found := TRUE;
exit;
end if;
end loop;
if not Found and
not SP.Equal(Arg.typename, "BOOLEAN") and
not SP.Equal(Arg.typename, "CHARACTER") then
TEXT_IO.PUT("type");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
TEXT_IO.PUT(" is ");
TEXT_IO.PUT(Left_Enclosure);
Write_List_Horizontal(Arg.valid);
TEXT_IO.PUT(Right_Enclosure);
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.listname, Argx.listname) then
Found := TRUE;
exit;
end if;
end loop;
if not Found then
TEXT_IO.PUT("type");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtypename));
TEXT_IO.PUT(" is array (POSITIVE range <>) of ");
TEXT_IO.PUT(SP.Value(Arg.typename));
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
when INT =>
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.typename, Argx.typename) then
Found := TRUE;
exit;
end if;
end loop;
if not Found and
not SP.Equal(Arg.typename, "INTEGER") and
not SP.Equal(Arg.typename, "POSITIVE") and
not SP.Equal(Arg.typename, "NATURAL") then
TEXT_IO.PUT("subtype");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
TEXT_IO.PUT(" is INTEGER range ");
TEXT_IO.PUT(SU.Image(Arg.low));
TEXT_IO.PUT(" .. ");
TEXT_IO.PUT(SU.Image(Arg.high));
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
when INT_LIST =>
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.typename, Argx.typename) then
Found := TRUE;
exit;
end if;
end loop;
if not Found and
not SP.Equal(Arg.typename, "INTEGER") and
not SP.Equal(Arg.typename, "POSITIVE") and
not SP.Equal(Arg.typename, "NATURAL") then
TEXT_IO.PUT("subtype");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
TEXT_IO.PUT(" is INTEGER range ");
TEXT_IO.PUT(SU.Image(Arg.low));
TEXT_IO.PUT(" .. ");
TEXT_IO.PUT(SU.Image(Arg.high));
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.listname, Argx.listname) then
Found := TRUE;
exit;
end if;
end loop;
if not Found then
TEXT_IO.PUT("type");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtypename));
TEXT_IO.PUT(" is array (POSITIVE range <>) of ");
TEXT_IO.PUT(SP.Value(Arg.typename));
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
when STR =>
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.typename, Argx.typename) then
Found := TRUE;
exit;
end if;
end loop;
if not Found and
not SP.Equal(Arg.typename, "STRING") then
TEXT_IO.PUT("subtype");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
TEXT_IO.PUT(" is STRING");
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
when STR_LIST =>
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.typename, Argx.typename) then
Found := TRUE;
exit;
end if;
end loop;
if not Found and
not SP.Equal(Arg.typename, "STRING") then
TEXT_IO.PUT("subtype");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
TEXT_IO.PUT(" is STRING");
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
Found := FALSE;
IterB := AL.MakeListIter(Proc.args);
while AL.More(IterB) loop
AL.Next(IterB, Argx);
if Arg = Argx then
exit;
elsif SP.Equal(Arg.listname, Argx.listname) then
Found := TRUE;
exit;
end if;
end loop;
if not Found then
TEXT_IO.PUT("type");
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtypename));
TEXT_IO.PUT(" is array (POSITIVE range <>) of ");
TEXT_IO.PUT(SP.Value(Arg.typename));
TEXT_IO.PUT(End_Delimiter);
New_Line(1);
end if;
end case;
end loop;
if not First then
New_Line(1);
end if;
TEXT_IO.PUT("procedure ");
TEXT_IO.PUT(SP.Value(Proc.name));
First := TRUE;
IterA := AL.MakeListIter(Proc.args);
while AL.More(IterA) loop
AL.Next(IterA, Arg);
if not First then
TEXT_IO.PUT(End_Delimiter);
else
First := FALSE;
TEXT_IO.PUT(Left_Enclosure);
end if;
New_Line(1);
TEXT_IO.SET_COL(4);
TEXT_IO.PUT(SS.Left_Justify(Arg.name, Proc.maxname));
TEXT_IO.PUT(" : in ");
case Arg.kind is
when ENUM | INT =>
if Arg.required then
TEXT_IO.PUT(SP.Value(Arg.typename));
else
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtype));
TEXT_IO.PUT(" := ");
Write_List_Horizontal(Arg.default);
end if;
when STR =>
if Arg.required then
TEXT_IO.PUT(SP.Value(Arg.typename));
else
TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtype));
TEXT_IO.PUT(" := """);
Write_List_Horizontal(Arg.default);
TEXT_IO.PUT('"');
end if;
when ENUM_LIST | INT_LIST =>
if Arg.required then
TEXT_IO.PUT(SP.Value(Arg.listname));
else
TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtype));
TEXT_IO.PUT(" := (");
Write_List_Horizontal(Arg.default, Quoted=>FALSE);
TEXT_IO.PUT(Right_Enclosure);
end if;
when STR_LIST =>
if Arg.required then
TEXT_IO.PUT(SP.Value(Arg.listname));
else
TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtype));
TEXT_IO.PUT(" := (");
Write_List_Horizontal(Arg.default, Quoted=>TRUE);
TEXT_IO.PUT(Right_Enclosure);
end if;
end case;
end loop;
if not First then
New_Line(1);
TEXT_IO.SET_COL(4);
TEXT_IO.PUT(Right_Enclosure);
end if;
TEXT_IO.PUT(End_Delimiter);
New_Line(2);
IterA := AL.MakeListIter(Proc.args);
if AL.More(IterA) then
while AL.More(IterA) loop
AL.Next(IterA, Arg);
S_Str := SP."&"(SS.Left_Justify(Arg.name, Proc.maxname), " : ");
Write_List_Vertical(SP.Value(S_Str), Arg.help);
end loop;
New_Line(1);
end if;
if not SL.IsEmpty(Proc.msgs) then
Write_List_Vertical("", Proc.msgs);
New_Line(1);
end if;
HL.Reset_Error;
SP.Release;
end Show_Help;
----------------------------------------------------------------
procedure Echo_Process(
Proc : in Process_Handle
) is
IterA : AL.ListIter;
Arg : Argument_Handle;
First : BOOLEAN;
Num : INTEGER;
begin
Check_Not_Yet_Parsed(Proc);
SP.Mark;
HL.Set_Error;
TEXT_IO.NEW_LINE(1);
TEXT_IO.PUT(SP.Value(Proc.name));
First := TRUE;
IterA := AL.MakeListIter(Proc.args);
while AL.More(IterA) loop
AL.Next(IterA, Arg);
if not First then
TEXT_IO.PUT(SP.Fetch(Delimiter, 1));
TEXT_IO.NEW_LINE(1);
else
First := FALSE;
TEXT_IO.PUT(" ( ");
Num := SP.Length(Proc.name) + 4;
end if;
TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Num));
TEXT_IO.PUT(SS.Left_Justify(Arg.name, Proc.maxname));
TEXT_IO.PUT(' ' & SP.Value(Assignment) & ' ');
case Arg.kind is
when ENUM | INT =>
if Arg.supplied then
Write_List_Horizontal(Arg.value);
else
Write_List_Horizontal(Arg.default);
end if;
when STR =>
if Arg.supplied then
Write_List_Horizontal(Arg.value, Quoted=>TRUE);
else
Write_List_Horizontal(Arg.default, Quoted=>TRUE);
end if;
when ENUM_LIST | INT_LIST =>
TEXT_IO.PUT(Left_Enclosure);
if Arg.supplied then
Write_List_Horizontal(Arg.value);
else
Write_List_Horizontal(Arg.default);
end if;
TEXT_IO.PUT(Right_Enclosure);
when STR_LIST =>
TEXT_IO.PUT(Left_Enclosure);
if Arg.supplied then
Write_List_Horizontal(Arg.value, Quoted=>TRUE);
else
Write_List_Horizontal(Arg.default, Quoted=>TRUE);
end if;
TEXT_IO.PUT(Right_Enclosure);
end case;
end loop;
if not First then
TEXT_IO.PUT(" )");
end if;
TEXT_IO.PUT(End_Delimiter);
TEXT_IO.NEW_LINE(2);
HL.Reset_Error;
SP.Release;
end Echo_Process;
----------------------------------------------------------------
function Continue(
Proc : in Process_Handle
) return BOOLEAN is
Reply : STRING (1 .. 256);
Len : NATURAL;
Str : SP.String_Type;
Ret : BOOLEAN := FALSE;
begin
Check_Not_Yet_Parsed(Proc);
HL.Set_Error;
TEXT_IO.PUT("Continue with procedure ");
TEXT_IO.PUT(SP.Value(Proc.name));
TEXT_IO.PUT(" ? (YES|NO) : ");
HL.Reset_Error;
TEXT_IO.GET_LINE(Reply, Len);
if Len = 0 then
return Continue(Proc);
end if;
SP.Mark;
if SP.Match_S(SP.Create("YES"), SP.Upper(STRING'(SU.Strip(Reply(1 .. Len))))) = 0 then
HL.Set_Error;
TEXT_IO.PUT_LINE("Aborting");
HL.Reset_Error;
else
Ret := TRUE;
end if;
SP.Release;
return Ret;
end Continue;
----------------------------------------------------------------
procedure Define_Output(
Proc : in Process_Handle;
File_Name : in STRING;
Header_Size : in Size := 0;
Paginate : in BOOLEAN := TRUE
) is
S_Str : SP.String_Type;
begin
if Paginate then
PO.Set_Standard_Paginated_File(File_Name, 66, Header_Size + 3, 2);
SP.Mark;
S_Str := SP."&"((SS.Left_Justify(Proc.name, 50) & ' '), File_Header);
PO.Set_Header(2, S_Str);
SP.Release;
else
PO.Set_Standard_Paginated_File(File_Name, 0, 0, 0);
end if;
end Define_Output;
----------------------------------------------------------------
procedure Define_Output(
Proc : in Process_Handle;
File_Name : in STRING;
Header_Size : in Size := 0;
File_Handle : in out PO.Paginated_File_Handle;
Paginate : in BOOLEAN := TRUE
) is
S_Str : SP.String_Type;
begin
if Paginate then
PO.Create_Paginated_File(File_Name, File_Handle, 66, Header_Size + 3, 2);
SP.Mark;
S_Str := SP."&"((SS.Left_Justify(Proc.name, 50) & ' '), File_Header);
PO.Set_Header(File_Handle, 2, S_Str);
SP.Release;
else
PO.Create_Paginated_File(File_Name, File_Handle, 0, 0, 0);
end if;
end Define_Output;
----------------------------------------------------------------
procedure Define_Header(
Line : in Number;
Text : in STRING
) is
begin
PO.Set_Header(Line + 2, Text);
end Define_Header;
----------------------------------------------------------------
procedure Define_Header(
File_Handle : in PO.Paginated_File_Handle;
Line : in Number;
Text : in STRING
) is
begin
PO.Set_Header(File_Handle, Line + 2, Text);
end Define_Header;
pragma Page;
package body Enumerated_Argument is
TypeColumn : POSITIVE := 6;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, ENUM, Enum_Type_Name, "", TRUE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
for i in Enum_Type loop
SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
end loop;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Default : in Enum_Type;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, ENUM, Enum_Type_Name, "", FALSE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
SL.Attach(Argument.default, SP.Make_Persistent(Enum_Type'image(Default)));
for i in Enum_Type loop
SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
end loop;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Destroy_Argument_Help(Proc, Name);
Set_Argument_Help(Proc, Name, Help);
end Define_Argument_Help;
----------------------------------------------------------------
procedure Append_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Set_Argument_Help(Proc, Name, Help);
end Append_Argument_Help;
----------------------------------------------------------------
function Get_Argument(
Proc : in Process_Handle;
Name : in STRING
) return Enum_Type is
begin
Check_Invalid_Kind(Proc, Name, ENUM);
if Get_Argument_Handle(Proc, Name).supplied then
return Enum_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).value)));
else
return Enum_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
end if;
end Get_Argument;
----------------------------------------------------------------
function Get_Default(
Proc : in Process_Handle;
Name : in STRING
) return Enum_Type is
begin
Check_Invalid_Kind(Proc, Name, ENUM);
if Get_Argument_Handle(Proc, Name).required then
raise No_Default;
else
return Enum_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
end if;
end Get_Default;
----------------------------------------------------------------
function Defaulted(
Proc : in Process_Handle;
Name : in STRING
) return BOOLEAN is
begin
Check_Invalid_Kind(Proc, Name, ENUM);
return not Get_Argument_Handle(Proc, Name).supplied;
end Defaulted;
----------------------------------------------------------------
begin
SP.Mark;
if SP.Equal(SP.Upper(Enum_Type_Name), "BOOLEAN") then
if Enum_Type'pos(Enum_Type'first) /= BOOLEAN'pos(BOOLEAN'first) or
Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
BOOLEAN'pos(BOOLEAN'last) - BOOLEAN'pos(BOOLEAN'first) then
raise Invalid_Type;
end if;
if Enum_Type'image(Enum_Type'first) /= BOOLEAN'image(BOOLEAN'first) or
Enum_Type'image(Enum_Type'last) /= BOOLEAN'image(BOOLEAN'last) then
raise Invalid_Type;
end if;
elsif SP.Equal(SP.Upper(Enum_Type_Name), "CHARACTER") then
if Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
CHARACTER'pos(CHARACTER'last) - CHARACTER'pos(CHARACTER'first) then
raise Invalid_Type;
end if;
if Enum_Type'image(Enum_Type'first) /= CHARACTER'image(CHARACTER'first) or
Enum_Type'image(Enum_Type'last) /= CHARACTER'image(CHARACTER'last) then
raise Invalid_Type;
end if;
end if;
SP.Release;
end Enumerated_Argument;
pragma Page;
package body Enumerated_List_Argument is
TypeColumn : POSITIVE := 6;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, ENUM_LIST, Enum_Type_Name, Enum_Type_List, TRUE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
for i in Enum_Type loop
SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
end loop;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Default : in Enum_Type_Array;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, ENUM_LIST, Enum_Type_Name, Enum_Type_List, FALSE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
for i in Default'range loop
SL.Attach(Argument.default, SP.Make_Persistent(Enum_Type'image(Default(i))));
end loop;
for i in Enum_Type loop
SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
end loop;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Destroy_Argument_Help(Proc, Name);
Set_Argument_Help(Proc, Name, Help);
end Define_Argument_Help;
----------------------------------------------------------------
procedure Append_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Set_Argument_Help(Proc, Name, Help);
end Append_Argument_Help;
----------------------------------------------------------------
function Get_Argument(
Proc : in Process_Handle;
Name : in STRING
) return EL.List is
List : EL.List := EL.Create;
Item : SP.String_Type;
Iterator : SL.ListIter;
begin
Check_Invalid_Kind(Proc, Name, ENUM_LIST);
if Get_Argument_Handle(Proc, Name).supplied then
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).value);
else
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
end if;
while SL.More(Iterator) loop
SL.Next(Iterator, Item);
EL.Attach(List, Enum_Type'value(SP.Value(Item)));
end loop;
return List;
end Get_Argument;
----------------------------------------------------------------
function Get_Default(
Proc : in Process_Handle;
Name : in STRING
) return EL.List is
List : EL.List := EL.Create;
Item : SP.String_Type;
Iterator : SL.ListIter;
begin
Check_Invalid_Kind(Proc, Name, ENUM_LIST);
if Get_Argument_Handle(Proc, Name).required then
raise No_Default;
else
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
end if;
while SL.More(Iterator) loop
SL.Next(Iterator, Item);
EL.Attach(List, Enum_Type'value(SP.Value(Item)));
end loop;
return List;
end Get_Default;
----------------------------------------------------------------
function Defaulted(
Proc : in Process_Handle;
Name : in STRING
) return BOOLEAN is
begin
Check_Invalid_Kind(Proc, Name, ENUM_LIST);
return not Get_Argument_Handle(Proc, Name).supplied;
end Defaulted;
----------------------------------------------------------------
begin
SP.Mark;
if SP.Equal(SP.Upper(Enum_Type_Name), "BOOLEAN") then
if Enum_Type'pos(Enum_Type'first) /= BOOLEAN'pos(BOOLEAN'first) or
Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
BOOLEAN'pos(BOOLEAN'last) - BOOLEAN'pos(BOOLEAN'first) then
raise Invalid_Type;
end if;
if Enum_Type'image(Enum_Type'first) /= BOOLEAN'image(BOOLEAN'first) or
Enum_Type'image(Enum_Type'last) /= BOOLEAN'image(BOOLEAN'last) then
raise Invalid_Type;
end if;
elsif SP.Equal(SP.Upper(Enum_Type_Name), "CHARACTER") then
if Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
CHARACTER'pos(CHARACTER'last) - CHARACTER'pos(CHARACTER'first) then
raise Invalid_Type;
end if;
if Enum_Type'image(Enum_Type'first) /= CHARACTER'image(CHARACTER'first) or
Enum_Type'image(Enum_Type'last) /= CHARACTER'image(CHARACTER'last) then
raise Invalid_Type;
end if;
end if;
SP.Release;
end Enumerated_List_Argument;
pragma Page;
package body Integer_Argument is
TypeColumn : POSITIVE := 6;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, INT, Integer_Type_Name, "", TRUE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
Argument.low := Integer_Type'pos(Integer_Type'first);
Argument.high := Integer_Type'pos(Integer_Type'last);
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Default : in Integer_Type;
Help : in STRING
) is
Str : SP.String_Type;
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, INT, Integer_Type_Name, "", FALSE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
SP.Mark;
Str := SS.Image(INTEGER'value(Integer_Type'image(Default)));
SL.Attach(Argument.default, SP.Make_Persistent(Str));
SP.Release;
Argument.low := Integer_Type'pos(Integer_Type'first);
Argument.high := Integer_Type'pos(Integer_Type'last);
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Destroy_Argument_Help(Proc, Name);
Set_Argument_Help(Proc, Name, Help);
end Define_Argument_Help;
----------------------------------------------------------------
procedure Append_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Set_Argument_Help(Proc, Name, Help);
end Append_Argument_Help;
----------------------------------------------------------------
function Get_Argument(
Proc : in Process_Handle;
Name : in STRING
) return Integer_Type is
begin
Check_Invalid_Kind(Proc, Name, INT);
if Get_Argument_Handle(Proc, Name).supplied then
return Integer_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).value)));
else
return Integer_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
end if;
end Get_Argument;
----------------------------------------------------------------
function Get_Default(
Proc : in Process_Handle;
Name : in STRING
) return Integer_Type is
begin
Check_Invalid_Kind(Proc, Name, INT);
if Get_Argument_Handle(Proc, Name).required then
raise No_Default;
else
return Integer_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
end if;
end Get_Default;
----------------------------------------------------------------
function Defaulted(
Proc : in Process_Handle;
Name : in STRING
) return BOOLEAN is
begin
Check_Invalid_Kind(Proc, Name, INT);
return not Get_Argument_Handle(Proc, Name).supplied;
end Defaulted;
----------------------------------------------------------------
begin
SP.Mark;
if SP.Equal(SP.Upper(Integer_Type_Name), "NATURAL") then
if Integer_Type'pos(Integer_Type'first) /= NATURAL'first or
Integer_Type'pos(Integer_Type'last) /= NATURAL'last then
raise Invalid_Type;
end if;
TypeColumn := 9;
elsif SP.Equal(SP.Upper(Integer_Type_Name), "POSITIVE") then
if Integer_Type'pos(Integer_Type'first) /= POSITIVE'first or
Integer_Type'pos(Integer_Type'last) /= POSITIVE'last then
raise Invalid_Type;
end if;
TypeColumn := 9;
elsif SP.Equal(SP.Upper(Integer_Type_Name), "INTEGER") then
if Integer_Type'pos(Integer_Type'first) /= INTEGER'first or
Integer_Type'pos(Integer_Type'last) /= INTEGER'last then
raise Invalid_Type;
end if;
TypeColumn := 9;
end if;
SP.Release;
end Integer_Argument;
pragma Page;
package body Integer_List_Argument is
TypeColumn : POSITIVE := 6;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, INT_LIST, Integer_Type_Name, Integer_Type_List, TRUE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
Argument.low := Integer_Type'pos(Integer_Type'first);
Argument.high := Integer_Type'pos(Integer_Type'last);
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Default : in Integer_Type_Array;
Help : in STRING
) is
Str : SP.String_Type;
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, INT_LIST, Integer_Type_Name, Integer_Type_List, FALSE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
for i in Default'range loop
SP.Mark;
Str := SS.Image(INTEGER'value(Integer_Type'image(Default(i))));
SL.Attach(Argument.default, SP.Make_Persistent(Str));
SP.Release;
end loop;
Argument.low := Integer_Type'pos(Integer_Type'first);
Argument.high := Integer_Type'pos(Integer_Type'last);
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Destroy_Argument_Help(Proc, Name);
Set_Argument_Help(Proc, Name, Help);
end Define_Argument_Help;
----------------------------------------------------------------
procedure Append_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Set_Argument_Help(Proc, Name, Help);
end Append_Argument_Help;
----------------------------------------------------------------
function Get_Argument(
Proc : in Process_Handle;
Name : in STRING
) return IL.List is
List : IL.List := IL.Create;
Item : SP.String_Type;
Iterator : SL.ListIter;
begin
Check_Invalid_Kind(Proc, Name, INT_LIST);
if Get_Argument_Handle(Proc, Name).supplied then
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).value);
else
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
end if;
while SL.More(Iterator) loop
SL.Next(Iterator, Item);
IL.Attach(List, INTEGER'value(SP.Value(Item)));
end loop;
return List;
end Get_Argument;
----------------------------------------------------------------
function Get_Default(
Proc : in Process_Handle;
Name : in STRING
) return IL.List is
List : IL.List := IL.Create;
Item : SP.String_Type;
Iterator : SL.ListIter;
begin
Check_Invalid_Kind(Proc, Name, INT_LIST);
if Get_Argument_Handle(Proc, Name).required then
raise No_Default;
else
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
end if;
while SL.More(Iterator) loop
SL.Next(Iterator, Item);
IL.Attach(List, INTEGER'value(SP.Value(Item)));
end loop;
return List;
end Get_Default;
----------------------------------------------------------------
function Defaulted(
Proc : in Process_Handle;
Name : in STRING
) return BOOLEAN is
begin
Check_Invalid_Kind(Proc, Name, INT_LIST);
return not Get_Argument_Handle(Proc, Name).supplied;
end Defaulted;
----------------------------------------------------------------
begin
SP.Mark;
if SP.Equal(SP.Upper(Integer_Type_Name), "NATURAL") then
if Integer_Type'pos(Integer_Type'first) /= NATURAL'first or
Integer_Type'pos(Integer_Type'last) /= NATURAL'last then
raise Invalid_Type;
end if;
TypeColumn := 9;
elsif SP.Equal(SP.Upper(Integer_Type_Name), "POSITIVE") then
if Integer_Type'pos(Integer_Type'first) /= POSITIVE'first or
Integer_Type'pos(Integer_Type'last) /= POSITIVE'last then
raise Invalid_Type;
end if;
TypeColumn := 9;
elsif SP.Equal(SP.Upper(Integer_Type_Name), "INTEGER") then
if Integer_Type'pos(Integer_Type'first) /= INTEGER'first or
Integer_Type'pos(Integer_Type'last) /= INTEGER'last then
raise Invalid_Type;
end if;
TypeColumn := 9;
end if;
SP.Release;
end Integer_List_Argument;
pragma Page;
package body String_Argument is
TypeColumn : POSITIVE := 6;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, STR, String_Type_Name, "", TRUE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Default : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, STR, String_Type_Name, "", FALSE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
SL.Attach(Argument.default, SP.Make_Persistent(Default));
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Destroy_Argument_Help(Proc, Name);
Set_Argument_Help(Proc, Name, Help);
end Define_Argument_Help;
----------------------------------------------------------------
procedure Append_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Set_Argument_Help(Proc, Name, Help);
end Append_Argument_Help;
----------------------------------------------------------------
function Get_Argument(
Proc : in Process_Handle;
Name : in STRING
) return SP.String_Type is
begin
Check_Invalid_Kind(Proc, Name, STR);
if Get_Argument_Handle(Proc, Name).supplied then
return SP.Make_Persistent(SL.FirstValue(Get_Argument_Handle(Proc, Name).value));
else
return SP.Make_Persistent(SL.FirstValue(Get_Argument_Handle(Proc, Name).default));
end if;
end Get_Argument;
----------------------------------------------------------------
function Get_Default(
Proc : in Process_Handle;
Name : in STRING
) return SP.String_Type is
begin
Check_Invalid_Kind(Proc, Name, STR);
if Get_Argument_Handle(Proc, Name).required then
raise No_Default;
else
return SP.Make_Persistent(SL.FirstValue(Get_Argument_Handle(Proc, Name).default));
end if;
end Get_Default;
----------------------------------------------------------------
function Defaulted(
Proc : in Process_Handle;
Name : in STRING
) return BOOLEAN is
begin
Check_Invalid_Kind(Proc, Name, STR);
return not Get_Argument_Handle(Proc, Name).supplied;
end Defaulted;
----------------------------------------------------------------
begin
SP.Mark;
if not SP.Equal(SP.Upper(String_Type_Name), "STRING") then
TypeColumn := 9;
end if;
SP.Release;
end String_Argument;
pragma Page;
package body String_List_Argument is
TypeColumn : POSITIVE := 6;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Argument : Argument_Handle;
begin
Argument := Set_Argument(Proc, Name, STR_LIST, String_Type_Name, String_Type_List, TRUE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument(
Proc : in Process_Handle;
Name : in STRING;
Default : in SL.List;
Help : in STRING
) is
Argument : Argument_Handle;
Def_Iter : SL.ListIter;
Def_Val : SP.String_Type;
begin
Argument := Set_Argument(Proc, Name, STR_LIST, String_Type_Name, String_Type_List, FALSE);
if Proc.typecolumn < TypeColumn then
Proc.typecolumn := TypeColumn;
end if;
Def_Iter := SL.MakeListIter(Default);
while SL.More(Def_Iter) loop
SL.Next(Def_Iter, Def_Val);
SL.Attach(Argument.default, SP.Make_Persistent(Def_Val));
end loop;
Define_Argument_Help(Proc, Name, Help);
end Define_Argument;
----------------------------------------------------------------
procedure Define_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Destroy_Argument_Help(Proc, Name);
Set_Argument_Help(Proc, Name, Help);
end Define_Argument_Help;
----------------------------------------------------------------
procedure Append_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
begin
Set_Argument_Help(Proc, Name, Help);
end Append_Argument_Help;
----------------------------------------------------------------
function Get_Argument(
Proc : in Process_Handle;
Name : in STRING
) return SL.List is
List : SL.List := SL.Create;
Item : SP.String_Type;
Iterator : SL.ListIter;
begin
Check_Invalid_Kind(Proc, Name, STR_LIST);
if Get_Argument_Handle(Proc, Name).supplied then
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).value);
else
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
end if;
while SL.More(Iterator) loop
SL.Next(Iterator, Item);
SL.Attach(List, Item);
end loop;
return List;
end Get_Argument;
----------------------------------------------------------------
function Get_Default(
Proc : in Process_Handle;
Name : in STRING
) return SL.List is
List : SL.List := SL.Create;
Item : SP.String_Type;
Iterator : SL.ListIter;
begin
Check_Invalid_Kind(Proc, Name, STR_LIST);
if Get_Argument_Handle(Proc, Name).required then
raise No_Default;
else
Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
end if;
while SL.More(Iterator) loop
SL.Next(Iterator, Item);
SL.Attach(List, Item);
end loop;
return List;
end Get_Default;
----------------------------------------------------------------
function Defaulted(
Proc : in Process_Handle;
Name : in STRING
) return BOOLEAN is
begin
Check_Invalid_Kind(Proc, Name, STR_LIST);
return not Get_Argument_Handle(Proc, Name).supplied;
end Defaulted;
----------------------------------------------------------------
begin
SP.Mark;
if not SP.Equal(SP.Upper(String_Type_Name), "STRING") then
TypeColumn := 9;
end if;
SP.Release;
end String_List_Argument;
pragma Page;
package body Command_Line is
----------------------------------------------------------------
procedure Show_Command_Help(
Handles : in Process_Handle_Array
) is
begin
Short_Help := TRUE;
New_Line(1);
for i in Command_Enumeration loop
Show_Help(Handles(i));
end loop;
New_Line(1);
Short_Help := FALSE;
end Show_Command_Help;
----------------------------------------------------------------
function Parse_Command_Line(
Handles : in Process_Handle_Array;
Line : in STRING
) return Command_Enumeration is
Scanner : SU.Scanner;
Found : BOOLEAN;
Cmd : SP.String_Type;
Arg : SP.String_Type;
Command : Command_Enumeration;
begin
if SU.Strip(Line) = "" then
if Command_Switches(Show_Help_on_Null) = ON then
Show_Command_Help(Handles);
end if;
raise No_Command;
end if;
SP.Mark;
Scanner := SU.Make_Scanner(SU.Strip(Line));
if SU.Is_Ada_Id(Scanner) then
SS.Scan_Ada_Id(Scanner, Found, Cmd);
else
SS.Scan_Word(Scanner, Found, Cmd);
end if;
declare
Command_String : STRING (1 .. SP.Length(Cmd)) := SP.Value(SP.Upper(Cmd));
begin
SP.Flush(Cmd);
Command := Command_Enumeration'value(Command_String);
SU.Skip_Space(Scanner);
Arg := SS.Get_Remainder(Scanner);
SU.Destroy_Scanner(Scanner);
Parse_Line(Handles(Command), SP.Value(Arg));
SP.Flush(Arg);
SP.Release;
return Command;
exception
when CONSTRAINT_ERROR =>
SU.Destroy_Scanner(Scanner);
if Command_String = "EXIT" then
SP.Release;
raise Command_Exit;
elsif Command_String = "HELP" then
if Command_Switches(Show_Help) = ON then
Show_Command_Help(Handles);
end if;
SP.Release;
raise Command_Help;
else
if Command_Switches(Show_Error) = ON then
Report_Error(Invalid_Command, Value=>Command_String);
end if;
if Command_Switches(Show_Help_on_Error) = ON then
Show_Command_Help(Handles);
end if;
SP.Release;
raise Abort_Command;
end if;
end;
raise Internal_Error;
end Parse_Command_Line;
end Command_Line;
pragma Page;
----------------------- Local Subprogams -----------------------
function Release return STRING is separate;
----------------------------------------------------------------
procedure Check_ID is
begin
if not Set_ID then
raise Identifier_Error;
end if;
end Check_ID;
----------------------------------------------------------------
procedure Check_Uninitialized(
Proc : in Process_Handle
) is
begin
if Proc = null then
Short_Help := FALSE;
raise Uninitialized;
end if;
end Check_Uninitialized;
----------------------------------------------------------------
procedure Check_Already_Exists(
Proc : in Process_Handle
) is
begin
if Proc /= null then
raise Already_Exists;
end if;
end Check_Already_Exists;
----------------------------------------------------------------
procedure Check_Invalid_Name(
Name : in STRING
) is
Scanner : SU.Scanner;
Str : SP.String_Type;
Found : BOOLEAN;
begin
SP.Mark;
Scanner := SS.Make_Scanner(SP.Create(Name));
SS.Scan_Ada_Id(Scanner, Found, Str);
SP.Release;
if Found then
SP.Flush(Str);
if SU.More(Scanner) then
Found := FALSE;
end if;
end if;
if not Found then
raise Invalid_Name;
end if;
end Check_Invalid_Name;
----------------------------------------------------------------
procedure Check_Undefined_Name(
Proc : in Process_Handle;
Name : in STRING
) is
Item : Argument_Handle;
begin
Check_Uninitialized(Proc);
Check_Invalid_Name(Name);
Item := Find_Match(Proc, Name);
if Item = null then
raise Undefined_Name;
end if;
end Check_Undefined_Name;
----------------------------------------------------------------
procedure Check_Duplicate_Name(
Proc : in Process_Handle;
Name : in STRING
) is
begin
Check_Undefined_Name(Proc, Name);
raise Duplicate_Name;
exception
when Undefined_Name =>
null;
end Check_Duplicate_Name;
----------------------------------------------------------------
procedure Check_Not_Yet_Parsed(
Proc : in Process_Handle
) is
begin
Check_Uninitialized(Proc);
if not Proc.parsed then
raise Not_Yet_Parsed;
end if;
end Check_Not_Yet_Parsed;
----------------------------------------------------------------
procedure Check_Already_Parsed(
Proc : in Process_Handle
) is
begin
Check_Uninitialized(Proc);
if Proc.parsed then
raise Already_Parsed;
end if;
end Check_Already_Parsed;
----------------------------------------------------------------
procedure Check_Invalid_Kind(
Proc : in Process_Handle;
Name : in STRING;
Kind : in Argument_Kind
) is
begin
Check_Undefined_Name(Proc, Name);
Check_Not_Yet_Parsed(Proc);
if Get_Argument_Handle(Proc, Name).kind /= Kind then
raise Invalid_Kind;
end if;
end Check_Invalid_Kind;
----------------------------------------------------------------
procedure Write(
Text : in STRING
) is
begin
TEXT_IO.PUT_LINE(Text);
end Write;
----------------------------------------------------------------
procedure New_Line(
Count : in POSITIVE
) is
begin
TEXT_IO.NEW_LINE(TEXT_IO.POSITIVE_COUNT(Count));
end New_Line;
----------------------------------------------------------------
procedure Write_List_Vertical(
Header : in STRING;
List : in SL.List
) is
B_Str : SP.String_Type;
Iter : SL.ListIter;
Done : BOOLEAN := FALSE;
begin
TEXT_IO.PUT("-- ");
TEXT_IO.PUT(Header);
Iter := SL.MakeListIter(List);
while SL.More(Iter) loop
SP.Mark;
SL.Next(Iter, B_Str);
if Done then
TEXT_IO.PUT("-- ");
declare
Blanks : STRING (1 .. Header'length) := (others => ' ');
begin
TEXT_IO.PUT(Blanks);
end;
else
Done := TRUE;
end if;
begin
Write(SP.Value(B_Str));
SP.Release;
exception
when others =>
SP.Release;
raise;
end;
end loop;
if not Done then
New_Line(1);
end if;
end Write_List_Vertical;
----------------------------------------------------------------
procedure Write_List_Horizontal(
List : in SL.List;
Quoted : in BOOLEAN := FALSE
) is
B_Str : SP.String_Type;
Iter : SL.ListIter;
First : BOOLEAN := TRUE;
begin
Iter := SL.MakeListIter(List);
while SL.More(Iter) loop
if not First then
TEXT_IO.PUT(SP.Fetch(Delimiter, 1) & " ");
else
First := FALSE;
end if;
SP.Mark;
SL.Next(Iter, B_Str);
if Quoted then
B_Str := SP."&"("""", B_Str);
B_Str := SP."&"(B_STR, """");
end if;
TEXT_IO.PUT(SP.Value(B_Str));
SP.Release;
end loop;
end Write_List_Horizontal;
----------------------------------------------------------------
function Find_Match(
Proc : in Process_Handle;
Name : in STRING
) return Argument_Handle is
Iterator : AL.ListIter;
Item : Argument_Handle;
begin
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) loop
AL.Next(Iterator, Item);
if SP.Equal(Item.name, SP.Upper(Name)) then
return Item;
end if;
end loop;
return null;
end Find_Match;
----------------------------------------------------------------
function Get_Argument_Handle(
Proc : in Process_Handle;
Name : in STRING
) return Argument_Handle is
Item : Argument_Handle;
begin
Check_Invalid_Name(Name);
Check_Undefined_Name(Proc, Name);
return Find_Match(Proc, Name);
end Get_Argument_Handle;
----------------------------------------------------------------
procedure Destroy_Argument_Help(
Proc : in Process_Handle;
Name : in STRING
) is
Iterator : AL.ListIter;
Item : Argument_Handle;
begin
Check_Invalid_Name(Name);
Check_Already_Parsed(Proc);
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) loop
AL.Next(Iterator, Item);
if SP.Equal(Item.name, SP.Upper(Name)) then
Destroy_String_List(Item.help);
Item.help := SL.Create;
return;
end if;
end loop;
raise Undefined_Name;
end Destroy_Argument_Help;
----------------------------------------------------------------
procedure Set_Argument_Help(
Proc : in Process_Handle;
Name : in STRING;
Help : in STRING
) is
Iterator : AL.ListIter;
Item : Argument_Handle;
begin
Check_Invalid_Name(Name);
Check_Already_Parsed(Proc);
Iterator := AL.MakeListIter(Proc.args);
while AL.More(Iterator) loop
AL.Next(Iterator, Item);
if SP.Equal(Item.name, SP.Upper(Name)) then
SL.Attach(Item.help, SP.Make_Persistent(Help));
return;
end if;
end loop;
raise Undefined_Name;
end Set_Argument_Help;
----------------------------------------------------------------
function Set_Argument(
Proc : in Process_Handle;
Name : in STRING;
Kind : in Argument_Kind;
Typename : in STRING;
Listname : in STRING;
Required : in BOOLEAN
) return Argument_Handle is
Argument : Argument_Handle;
begin
Check_Duplicate_Name(Proc, Name);
Check_Invalid_Name(Typename);
if Listname /= "" then
Check_Invalid_Name(Listname);
end if;
Check_Already_Parsed(Proc);
Argument := new Argument_Record;
SP.Mark;
Argument.name := SP.Make_Persistent(SP.Upper(Name));
Argument.typename := SP.Make_Persistent(SP.Upper(Typename));
Argument.listname := SP.Make_Persistent(SP.Upper(Listname));
Argument.required := Required;
Argument.kind := Kind;
AL.Attach(Proc.args, Argument);
SP.Release;
if Proc.maxname < Name'length then
Proc.maxname := Name'length;
end if;
if Proc.maxtypename < Typename'length then
case Kind is
when ENUM | ENUM_LIST =>
if not SP.Equal(Argument.typename, "BOOLEAN") and
not SP.Equal(Argument.typename, "CHARACTER") then
Proc.maxtypename := Typename'length;
end if;
when INT | INT_LIST =>
if not SP.Equal(Argument.typename, "INTEGER") and
not SP.Equal(Argument.typename, "POSITIVE") and
not SP.Equal(Argument.typename, "NATURAL") then
Proc.maxtypename := Typename'length;
end if;
when STR | STR_LIST =>
if not SP.Equal(Argument.typename, "STRING") then
Proc.maxtypename := Typename'length;
end if;
end case;
end if;
case Kind is
when ENUM | INT | STR =>
if Proc.maxtype < Typename'length then
Proc.maxtype := Typename'length;
end if;
when ENUM_LIST | INT_LIST | STR_LIST =>
if Proc.maxtype < Listname'length then
Proc.maxtype := Listname'length;
end if;
if Proc.maxtypename < Listname'length then
Proc.maxtypename := Listname'length;
end if;
end case;
return Argument;
end Set_Argument;
----------------------------------------------------------------
procedure Point_Next_Token(
Scanner : in SU.Scanner
) is
begin
SU.Skip_Space(Scanner);
if SU.More(Scanner) and then SS.Is_Sequence(Delimiter, Scanner) then
SU.Forward(Scanner);
SU.Skip_Space(Scanner);
end if;
end Point_Next_Token;
----------------------------------------------------------------
procedure Get_Next_Token(
Scanner : in SU.Scanner;
Kind : out Token_Kind;
Token : in out SP.String_Type
) is
S_Str : SP.String_Type;
Scan_Arg : SU.Scanner;
Found : BOOLEAN;
Inx1 : POSITIVE;
Inx2 : POSITIVE;
begin
if not SU.More(Scanner) then
Kind := DONE;
return;
end if;
if SU.Is_Quoted(Scanner) or SU.Is_Enclosed(Left_Enclosure, Right_Enclosure, Scanner) then
Inx1 := SU.Position(Scanner);
SU.Mark(Scanner);
SS.Scan_Quoted(Scanner, Found, S_Str);
if not Found then
SS.Scan_Enclosed(Left_Enclosure, Right_Enclosure, Scanner, Found, S_Str);
end if;
if not SS.Is_Sequence(Delimiter, Scanner) and not SS.Is_Literal(Assignment, Scanner) then
SU.Skip_Space(Scanner);
end if;
if not SS.Is_Sequence(Delimiter, Scanner) and not SS.Is_Literal(Assignment, Scanner) then
while not SS.Is_Sequence(Delimiter, Scanner) and
not SS.Is_Literal(Assignment, Scanner) loop
SU.Forward(Scanner);
end loop;
SU.Unmark(Scanner);
Inx2 := SU.Position(Scanner);
S_Str := SS.Get_String(Scanner);
Token := SP.Make_Persistent(SP.Substr(S_Str, Inx1, Inx2 - Inx1));
SP.Flush(S_Str);
if SS.Is_Literal(Assignment, Scanner) then
Kind := NAME;
else
Kind := VALUE;
end if;
return;
end if;
SU.Restore(Scanner);
end if;
SP.Mark;
if SU.Is_Quoted(Scanner) then
SS.Scan_Quoted(Scanner, Found, Token);
Kind := QUOTED;
elsif SU.Is_Enclosed(Left_Enclosure, Right_Enclosure, Scanner) then
SS.Scan_Enclosed(Left_Enclosure, Right_Enclosure, Scanner, Found, S_Str);
Token := SP.Make_Persistent(STRING'(SS.Strip(S_Str)));
Kind := LIST;
SP.Flush(S_Str);
elsif SS.Is_Not_Sequence(Delimiter, Scanner) then
SU.Mark(Scanner);
SS.Scan_Not_Sequence(Delimiter, Scanner, Found, S_Str);
Scan_Arg := SS.Make_Scanner(S_Str);
SP.Flush(S_Str);
SU.Restore(Scanner);
if SS.Is_Literal(Assignment, Scan_Arg) then
SS.Scan_Literal(Assignment, Scanner, Found);
Kind := BIND;
elsif SS.Is_Not_Literal(Assignment, Scan_Arg) then
SS.Scan_Not_Literal(Assignment, Scanner, Found, S_Str);
Kind := NAME;
Token := SP.Make_Persistent(STRING'(SS.Strip_Trailing(S_Str)));
SP.Flush(S_Str);
else
SS.Scan_Not_Sequence(Delimiter, Scanner, Found, S_Str);
SU.Skip_Space(Scanner);
if SS.Is_Literal(Assignment, Scanner) then
Kind := NAME;
else
Kind := VALUE;
end if;
Token := SP.Make_Persistent(STRING'(SS.Strip_Trailing(S_Str)));
SP.Flush(S_Str);
end if;
SU.Destroy_Scanner(Scan_Arg);
else
Kind := NONE;
end if;
Point_Next_Token(Scanner);
SP.Release;
end Get_Next_Token;
----------------------------------------------------------------
procedure Parse_Argument(
Argument : in Argument_Handle;
Item : in SP.String_Type;
Kind : in Token_Kind
) is
Iterator : SL.ListIter;
Num : INTEGER;
R_Str : SP.String_Type;
S_Str : SP.String_Type;
Element : SP.String_Type;
Scanner : SU.Scanner;
Found : BOOLEAN;
First : BOOLEAN;
List_Error : BOOLEAN := FALSE;
begin
case Argument.kind is
when ENUM =>
if Kind = VALUE then
Iterator := SL.MakeListIter(Argument.valid);
while SL.More(Iterator) loop
SL.Next(Iterator, R_Str);
if SP.Equal(SP.Upper(Item), R_Str) then
SL.Attach(Argument.value, SP.Make_Persistent(R_Str));
Argument.supplied := TRUE;
return;
end if;
end loop;
end if;
when INT =>
if Kind = VALUE then
begin
Num := INTEGER'value(SP.Value(Item));
if Argument.low <= Num and Num <= Argument.high then
SL.Attach(Argument.value, SP.Make_Persistent(Item));
Argument.supplied := TRUE;
return;
end if;
exception
when CONSTRAINT_ERROR =>
null;
end;
end if;
when STR =>
if Kind = QUOTED or Parsing_Switches(Quote_Enclosure) = OFF then
SL.Attach(Argument.value, SP.Make_Persistent(Item));
Argument.supplied := TRUE;
return;
else
Report_Error(Missing_Quotes, Value=>SP.Value(Item));
end if;
when ENUM_LIST =>
if Kind = LIST or
(Parsing_Switches(Argument_Enclosure) = OFF and Kind = VALUE) then
Scanner := SS.Make_Scanner(SP."&"(Item, "" & SP.Fetch(Delimiter, 1)));
First := TRUE;
while SU.More(Scanner) loop
SS.Scan_Not_Sequence(Delimiter, Scanner, Found, Element, Skip => TRUE);
S_Str := SP.Upper(STRING'(SS.Strip_Trailing(Element)));
Iterator := SL.MakeListIter(Argument.valid);
Found := FALSE;
while SL.More(Iterator) loop
SL.Next(Iterator, R_Str);
if SP.Equal(S_Str, R_Str) then
SL.Attach(Argument.value, SP.Make_Persistent(R_Str));
Found := TRUE;
exit;
end if;
end loop;
if not Found then
if not First then
if not SP.Is_Empty(S_Str) then
Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
else
if not List_Error then
Report_Error(Invalid_List,
Value => Left_Enclosure &
SP.Value(Item) &
Right_Enclosure);
List_Error := TRUE;
end if;
end if;
else
if not SP.Is_Empty(S_Str) then
Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
else
Argument.supplied := TRUE;
end if;
end if;
else
Argument.supplied := TRUE;
end if;
SP.Flush(Element);
Point_Next_Token(Scanner);
First := FALSE;
end loop;
return;
end if;
when INT_LIST =>
if Kind = LIST or
(Parsing_Switches(Argument_Enclosure) = OFF and Kind = VALUE) then
Scanner := SS.Make_Scanner(SP."&"(Item, "" & SP.Fetch(Delimiter, 1)));
First := TRUE;
while SU.More(Scanner) loop
SS.Scan_Not_Sequence(Delimiter, Scanner, Found, Element, Skip => TRUE);
S_Str := SS.Strip_Trailing(Element);
Found := FALSE;
begin
Num := INTEGER'value(SP.Value(S_Str));
if Argument.low <= Num and Num <= Argument.high then
SL.Attach(Argument.value, SP.Make_Persistent(S_Str));
Found := TRUE;
end if;
exception
when CONSTRAINT_ERROR =>
null;
end;
if not Found then
if not First then
if not SP.Is_Empty(S_Str) then
Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
else
if not List_Error then
Report_Error(Invalid_List,
Value => Left_Enclosure &
SP.Value(Item) &
Right_Enclosure);
List_Error := TRUE;
end if;
end if;
else
if not SP.Is_Empty(S_Str) then
Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
else
Argument.supplied := TRUE;
end if;
end if;
else
Argument.supplied := TRUE;
end if;
SP.Flush(Element);
Point_Next_Token(Scanner);
First := FALSE;
end loop;
return;
end if;
when STR_LIST =>
if Kind = LIST or
Parsing_Switches(Argument_Enclosure) = OFF then
Scanner := SS.Make_Scanner(SP."&"(Item, "" & SP.Fetch(Delimiter, 1)));
First := TRUE;
while SU.More(Scanner) loop
if Kind = LIST then
if SU.Is_Quoted(Scanner) then
SS.Scan_Quoted(Scanner, Found, Element);
else
SS.Scan_Not_Sequence(Delimiter, Scanner, Found, Element, Skip => TRUE);
if Parsing_Switches(Quote_Enclosure) = ON and
not SP.Is_Empty(SS.Strip(Element)) then
Report_Error(Missing_Quotes, Value=>SP.Value(Element));
end if;
end if;
S_Str := SS.Strip_Trailing(Element);
else
S_Str := SS.Get_String(Scanner);
Element := SP.Make_Persistent(SP.Substr(S_Str, 1, SP.Length(S_Str) - 1));
SP.Flush(S_Str);
if Kind /= QUOTED then
S_Str := SS.Strip(Element);
else
S_Str := Element;
end if;
SU.Backward(Scanner);
end if;
if SP.Is_Empty(S_Str) then
if not First then
if not List_Error then
Report_Error(Invalid_List,
Value => Left_Enclosure &
SP.Value(Item) &
Right_Enclosure);
List_Error := TRUE;
end if;
else
Argument.supplied := TRUE;
end if;
else
Argument.supplied := TRUE;
SL.Attach(Argument.value, SP.Make_Persistent(S_Str));
end if;
SP.Flush(Element);
Point_Next_Token(Scanner);
First := FALSE;
end loop;
return;
end if;
end case;
case Kind is
when LIST =>
Report_Error(Invalid_List,
Value => Left_Enclosure &
SP.Value(S_Str) &
Right_Enclosure);
Report_Error(Invalid_List, Value=>SP.Value(S_Str));
when QUOTED =>
S_Str := SP.Create('"' & SP.Value(Item) & '"');
Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
when others =>
Report_Error(Invalid_Value, Value=>SP.Value(Item));
end case;
end Parse_Argument;
----------------------------------------------------------------
procedure Report_Error(
Kind : in Error_Types;
Argument : in STRING := "";
Name : in STRING := "";
Value : in STRING := ""
) is
S_Str : SP.String_Type;
Num : NATURAL;
begin
if Errors(Kind).flag = CONTINUE then
Status := ERROR;
else
Status := SEVERE;
end if;
if Action_Switches(Show_Error) = OFF then
return;
end if;
SP.Mark;
S_Str := Errors(Kind).msg;
loop
Num := SP.Match_S(S_Str, "~A");
exit when Num = 0;
S_Str := SP.Splice(S_Str, Num, 2);
S_Str := SP.Insert(S_Str, Argument, Num);
end loop;
loop
Num := SP.Match_S(S_Str, "~N");
exit when Num = 0;
S_Str := SP.Splice(S_Str, Num, 2);
S_Str := SP.Insert(S_Str, Name, Num);
end loop;
loop
Num := SP.Match_S(S_Str, "~V");
exit when Num = 0;
S_Str := SP.Splice(S_Str, Num, 2);
S_Str := SP.Insert(S_Str, Value, Num);
end loop;
HL.Put_Error(SP.Value(S_Str));
SP.Release;
end Report_Error;
----------------------------------------------------------------
end Standard_Interface;
pragma Page;
--::::::::::
--release.sub
--::::::::::
separate (Standard_Interface)
function Release return STRING is
begin
return "3.01";
-- The executable's header line will contain the return string
-- as it appears above.
end Release;
--::::::::::
--hostlib.spc
--::::::::::
package Host_Lib is
--| Host dependent subprograms
--| Overview
--| This package provides a common interface to the user for functions whose
--| implementations are host dependent.
--|-
--| Set_Error Directs default output to appropriate error output
--| Reset_Error Resets above
--| Put_Error Writes an error message to appropriate error output
--| Return_Code Sets return code
--| Invoke Runs a program
--| Get_Item Returns specified item from the system
--| Read_No_Echo Returns keyboard without echoing
--| Protection Returns protection setting string
--| Get_Time Obtains current date/time
--| Date Returns current date (MM/DD/YY)
--| Calendar_Date Returns current date (eg. March 15, 1985)
--| Time Returns current time (HH:MM:SS)
--| Get_Terminal_Type Returns attached terminal type
--| Enable_Interrupt_Trap Enables trapping of interrupt from the keyboard
--| Disable_Interrupt_Trap Disables interrupt trapping
--| Ignore_Interrupts Ignore interrupts from the keyboard
--| Interrupts_Ignored Returns TRUE iff interrupt was ignored
--| Set_Interrupt_State Sets the interrupt trapping state
--| Get_Interrupt_State Returns the interrupt trapping state
--|+
----------------------------------------------------------------
Uninitialized_Time_Value : exception; --| Raised when time value not set
Terminal_Not_Attached : exception; --| Raised when no terminal attached
Unknown_Terminal_Type : exception; --| Raised when terminal unknown
Interrupt_Encountered : exception; --| Raised when Trap_Interrupts has
--| been called and an interrupt was
--| encountered.
----------------------------------------------------------------
type Severity_Code is ( --| Systen independent error indication
SUCCESS, INFORMATION, WARNING, ERROR, SEVERE
);
type Item_Type is ( --| Items to be obtained from system
ARGUMENTS, USER_NAME, ACCOUNT, PROGRAM_NAME, PROCESS_MODE,
PROCESS_ID, TERMINAL_ADDRESS, DEVICE_TYPE
);
type Time_Value is limited private; --| Current date/time marker
type Format is (RAW, EDIT); --| Return value format
type Permission is (YES, NO); --| Protection status
type Protection_Category is (READ, WRITE, EXECUTE, DELETE);
type Protection_Specification is array (Protection_Category) of Permission;
type Terminal_Type is ( --| Known terminal types
VT05,
VK100,
VT173,
TQ_BTS,
TEK401X,
FOREIGN_TERMINAL_1,
FOREIGN_TERMINAL_2,
FOREIGN_TERMINAL_3,
FOREIGN_TERMINAL_4,
FOREIGN_TERMINAL_5,
FOREIGN_TERMINAL_6,
FOREIGN_TERMINAL_7,
FOREIGN_TERMINAL_8,
LA36,
LA120,
LA34,
LA38,
LA12,
LA24,
LQP02,
LA84,
VT52,
VT55,
DZ11,
DZ32,
DZ730,
DMZ32,
DHV,
DHU,
VT100,
VT101,
VT102,
VT105,
VT125,
VT131,
VT132,
VT200_SERIES,
PRO_SERIES,
WORKSTATION, -- Workstations
VS100,
VS125,
VS300,
VIRTUAL_DEVICE);
type Interrupt_State is (ENABLED, DISABLED, IGNORED);
----------------------------------------------------------------
Max_Arg_Length : constant POSITIVE := 255;
--| Maximum chars per line
----------------------------------------------------------------
procedure Set_Error; --| Direct error output
--| Effects: Set the default output to an error output stream so that all
--| subsequent outputs without file_type specification is directed to the
--| error output.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Reset_Error; --| Resets the defualt output
--| Effects: Reset the default output to standard output. (Used in conjunction
--| with Set_Error.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Put_Error( --| Write a error message
Message : in STRING --| Message to be written
);
--| Effects: Writes the error message to the error output. The message is
--| prepended with an appropriate error message indication.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Return_Code( --| Set return code
Severity : in Severity_Code --| Return code to be set
) return INTEGER;
--| Effects: Sets a system dependent return value based on the given return
--| indication.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Invoke( --| Invoke a program
Process : in STRING; --| Name and arugment(s) of the program
Severity : out Severity_Code --| Systen independent error indication
);
--| Effects: Runs the specified program with the given arguments.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get_Item( --| Get specified item from system
Item : in Item_Type; --| Item to be obtained
Form : in Format := EDIT --| Format the result
) return STRING;
--| Raises : Terminal_Not_Attached, Unknown_Terminal_Type
--| Effects: Obtains the specified item from the system.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Read_No_Echo( --| Read a string from keyboard
Address : in STRING := Get_Item(TERMINAL_ADDRESS)
--| Terminal address
) return STRING;
--| Effects: Reads characters entered from the keyboard without echoing.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Protection( --| Read a string from keyboard
System : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
--| Protection for system
Owner : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
--| Protection for owner
Group : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
--| Protection for group
World : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES)
--| Protection for world
) return STRING;
--| Effects: Returns a string to be used in the FORM arugment of standard
--| I/O package Open/Create subprograms.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Get_Time( --| Get date/time
Value : out Time_Value --| Time value to be returned
);
--| Effects: Obaints current date/time.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function "="( --| Compare two date/time
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN;
--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if two date/times are equal; FALSE otherwise.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function "<"( --| Compare two date/time
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN;
--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is less than Right; FALSE otherwise.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function ">"( --| Compare two date/time
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN;
--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is greater than Right; FALSE otherwise.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function "<="( --| Compare two date/time
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN;
--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is less than or equal to Right; FALSE otherwise.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function ">="( --| Compare two date/time
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN;
--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is greater than or equal to Right; FALSE otherwise.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Date( --| Returns date
Value : in Time_Value --| Time value
) return STRING;
--| Raises : Uninitialized_Time_Value
--| Effects: Extract the date portion from Time_Value in MM/DD/YY format
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Calendar_Date( --| Returns calendar date
Value : in Time_Value --| Time value
) return STRING;
--| Raises : Uninitialized_Time_Value
--| Effects: Extract the date portion from Time_Value in Month DD, Year format
--| (eg. March 15, 1985)
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Time( --| Returns time
Value : in Time_Value --| Time value
) return STRING;
--| Raises : Uninitialized_Time_Value
--| Effects: Extract the time portion from Time_Value in HH:MM:SS format
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Get_Terminal_Type --| Get terminal type
return Terminal_Type;
--| Raises : Terminal_Not_Attached, Unknown_Terminal_Type
--| Effects: Obtains attached terminal type.
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Enable_Interrupt_Trap; --| Traps interrupt from the keyboard
--| Raises : Interrupt_Encountered
--| Effects: Enables trapping of an interrupt encountered from the keyboard.
--| On an interrupt from the keyboard, this procedure will :
--| 1. Set state such that all further interrupts from the keyboard are ignored
--| 2. Raise Interrupt_Encountered exception
--| It is the user's responsibility to handle the ignore state after the
--| exception is raised (eg. disable the interrupt trapping to allow the
--| system to handle subsequent interrupts).
--|-
--| begin
--| (Process not requiring interrupt trap)
--| Enable_Interrupt_Trap;
--| (Process requiring interrupt trap)
--| Ignore_Interrupts;
--| (Post process [eg. clean up])
--| exception
--| when Interrupt_Encountered =>
--| (Post process [eg. clean up])
--| end;
--| Disable_Interrupt_Trap
--|+
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Disable_Interrupt_Trap; --| Disables interrupt trapping
--| Effects: Disables trapping of interrupts encountered from the keyboard.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Ignore_Interrupts; --| Ignore interrupts
--| Effects: Interrupts encountered from the keyboard are ignored.
--| The trap must subsequently be disabled (Disable_Interrupt_Trap).
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Interrupts_Ignored --| Returns TRUE if any interrupts from
--| the keyboard were ignored
return BOOLEAN;
--| Effects: Returns TRUE if any interrupts were encountered since the mode
--| was set to ignore interrupts.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Set_Interrupt_State( --| Set interrupt state
State : in Interrupt_State
);
--| Effects: Set interrupt state
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get_Interrupt_State --| Get interrupt state
return Interrupt_State;
--| Effects: Returns interrupt state
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
private
pragma list(off);
type Time_Value is
record
year : INTEGER;
month : INTEGER := 0;
day : INTEGER;
time : INTEGER;
end record;
pragma list(on);
end Host_Lib;
pragma page;
--::::::::::
--hostlib.bdy
--::::::::::
with System; use System;
with Starlet;
with Condition_Handling;
with Text_IO;
with Calendar;
with String_Pkg;
with String_Utilities;
package body Host_Lib is
----------------------------------------------------------------
package SU renames String_Utilities;
package CAL renames Calendar;
package SP renames String_Pkg;
package CD renames Condition_Handling;
package TIO renames Text_IO;
package STL renames Starlet;
----------------------------------------------------------------
Month_Name : constant STRING :=
"JanuarayFebruarnyMarchAprilMayJune" &
"JulyAugustSeptemberOctoberNovemberDecember";
Index_Array : constant array (1..13) of INTEGER :=
(1, 9, 18, 23, 28, 31, 35, 39, 45, 54, 61, 69, 77);
Item_Array : constant array (1..7) of INTEGER :=
(STL.JPI_USERNAME,
STL.JPI_ACCOUNT,
STL.JPI_IMAGNAME,
STL.JPI_MODE,
STL.JPI_PID,
STL.JPI_TERMINAL,
STL.DVI_DEVTYPE);
Terminal_Array : constant array (Terminal_Type) of INTEGER := (
VT05 => 1,
VK100 => 2,
VT173 => 3,
TQ_BTS => 4,
TEK401X => 10,
FOREIGN_TERMINAL_1 => 16,
FOREIGN_TERMINAL_2 => 17,
FOREIGN_TERMINAL_3 => 18,
FOREIGN_TERMINAL_4 => 19,
FOREIGN_TERMINAL_5 => 20,
FOREIGN_TERMINAL_6 => 21,
FOREIGN_TERMINAL_7 => 22,
FOREIGN_TERMINAL_8 => 23,
LA36 => 32,
LA120 => 33,
LA34 => 34,
LA38 => 35,
LA12 => 36,
LA24 => 37,
LQP02 => 38,
LA84 => 39,
VT52 => 64,
VT55 => 65,
DZ11 => 66,
DZ32 => 67,
DZ730 => 68,
DMZ32 => 69,
DHV => 70,
DHU => 71,
VT100 => 96,
VT101 => 97,
VT102 => 98,
VT105 => 99,
VT125 => 100,
VT131 => 101,
VT132 => 102,
VT200_SERIES => 110,
PRO_SERIES => 111,
WORKSTATION => 0,
VS100 => 1,
VS125 => 2,
VS300 => 3,
VIRTUAL_DEVICE => 4);
Control_Y : constant UNSIGNED_LONGWORD := 2**CHARACTER'POS(ASCII.EM);
TT_Name : constant STRING := "TT:";
----------------------------------------------------------------
Error_File_Type : TIO.FILE_TYPE;
Error_Switch : NATURAL;
TT_Channel : STL.Channel_Type;
Condition : CD.Cond_Value_Type;
Status : INTEGER;
IOSB : STL.IOSB_Type;
Mask : UNSIGNED_LONGWORD;
Save_Mask : UNSIGNED_LONGWORD;
State : Interrupt_State;
Ignored_State : BOOLEAN;
----------------------- Local procedure ------------------------
procedure Spawn(
Status : out INTEGER;
Process : in STRING
);
pragma Interface(VAXRTL, Spawn);
pragma Import_Valued_Procedure(
Internal => Spawn,
External => "Lib$Spawn",
Parameter_Types => (INTEGER,
STRING),
Mechanism => (Value,
Descriptor(S)));
----------------------------------------------------------------
procedure Get_Foreign(
Arguments : out STRING
);
pragma Interface(External, Get_Foreign);
pragma Import_Valued_Procedure(Get_Foreign,
"Lib$Get_Foreign",
(STRING),
(Descriptor(S)));
----------------------------------------------------------------
procedure Get_JPI(
Status : out INTEGER;
Item_Code : in INTEGER;
Proc_Id : in ADDRESS := ADDRESS_ZERO;
Proc_Name : in STRING := STRING'NULL_PARAMETER;
Out_Value : in ADDRESS := ADDRESS_ZERO;
Out_String : out STRING;
Out_Len : out SHORT_INTEGER);
pragma Interface(VAXRTL, Get_JPI);
pragma Import_Valued_Procedure(
Internal => Get_JPI,
External => "LIB$GETJPI",
Parameter_Types => (INTEGER,
INTEGER,
ADDRESS,
STRING,
ADDRESS,
STRING,
SHORT_INTEGER),
Mechanism => (Value,
Reference,
Value,
Descriptor(S),
Value,
Descriptor(S),
Reference));
----------------------------------------------------------------
procedure Get_DVI(
Status : out INTEGER;
Item_Code : in INTEGER;
Channel : in SHORT_INTEGER := 0;
Dev_Name : in STRING;
Out_Value : in INTEGER := 0;
Out_String : out STRING;
Out_Len : out SHORT_INTEGER);
pragma Interface(VAXRTL, Get_DVI);
pragma Import_Valued_Procedure(
Internal => Get_DVI,
External => "LIB$GETDVI",
Parameter_Types => (INTEGER,
INTEGER,
SHORT_INTEGER,
STRING,
INTEGER,
STRING,
SHORT_INTEGER),
Mechanism => (Value,
Reference,
Reference,
Descriptor(S),
Reference,
Descriptor(S),
Reference));
----------------------------------------------------------------
function Get_Protection_String(
Name : in STRING;
Prot : in Protection_Specification
) return SP.String_Type is
Str : SP.String_Type := SP.Create("");
begin
if Prot(Read) = YES then
Str := SP."&"(Str, "R");
end if;
if Prot(Write) = YES then
Str := SP."&"(Str, "W");
end if;
if Prot(Execute) = YES then
Str := SP."&"(Str, "E");
end if;
if Prot(Delete) = YES then
Str := SP."&"(Str, "D");
end if;
if SP.Length(Str) /= 0 then
Str := SP."&"(Name & ':', Str);
Str := SP."&"(Str, ",");
end if;
return Str;
end Get_Protection_String;
----------------------------------------------------------------
procedure Check_Time_Value(
Value : Time_Value
) is
begin
if Value.month = 0 then
raise Uninitialized_Time_Value;
end if;
end Check_Time_Value;
----------------------------------------------------------------
function Compare(
Left : Time_Value;
Right : Time_Value
) return INTEGER is
Diff : INTEGER;
begin
Check_Time_Value(Left);
Check_Time_Value(Right);
Diff := Left.year - Right.year;
if Diff /= 0 then
return Diff;
end if;
Diff := Left.month - Right.month;
if Diff /= 0 then
return Diff;
end if;
Diff := Left.day - Right.day;
if Diff /= 0 then
return Diff;
end if;
return Left.time - Right.time;
end Compare;
----------------------------------------------------------------
procedure Signal(Status : in CD.Cond_Value_Type);
pragma Interface(VAXRTL, Signal);
pragma Import_Procedure(Signal, "LIB$Signal", Mechanism =>(Value));
----------------------------------------------------------------
procedure Control_Character_Handler is
begin
Ignore_Interrupts;
raise Interrupt_Encountered;
end Control_Character_Handler;
pragma Export_Procedure(Control_Character_Handler,
"Ada$Control_Character_Handler");
----------------------------------------------------------------
procedure Control_Character_Ignore is
begin
Ignore_Interrupts;
Ignored_State := TRUE;
end Control_Character_Ignore;
pragma Export_Procedure(Control_Character_Ignore,
"Ada$Control_Character_Ignore");
----------------------------------------------------------------
procedure Disable_Control(
Status : out INTEGER;
Mask : in UNSIGNED_LONGWORD;
Old_Mask : out UNSIGNED_LONGWORD
);
pragma Interface(VAXRTL, Disable_Control);
pragma Import_Valued_Procedure(
Internal => Disable_Control,
External => "Lib$Disable_Ctrl",
Parameter_Types => (INTEGER,
UNSIGNED_LONGWORD,
UNSIGNED_LONGWORD),
Mechanism => (Value,
Reference,
Reference));
----------------------------------------------------------------
procedure Enable_Control(
Status : out INTEGER;
Mask : in UNSIGNED_LONGWORD;
Old_Mask : out UNSIGNED_LONGWORD
);
pragma Interface(VAXRTL, Enable_Control);
pragma Import_Valued_Procedure(
Internal => Enable_Control,
External => "Lib$Enable_Ctrl",
Parameter_Types => (INTEGER,
UNSIGNED_LONGWORD,
UNSIGNED_LONGWORD),
Mechanism => (Value,
Reference,
Reference));
pragma page;
--------------------- Visible Subprograms ----------------------
procedure Set_Error is
begin
if Error_Switch = 0 then
TIO.SET_OUTPUT(File => Error_File_Type);
end if;
Error_Switch := Error_Switch + 1;
end Set_Error;
----------------------------------------------------------------
procedure Reset_Error is
begin
if Error_Switch < 1 then
return;
end if;
Error_Switch := Error_Switch - 1;
if Error_Switch = 0 then
TIO.SET_OUTPUT(File => TIO.STANDARD_OUTPUT);
end if;
end Reset_Error;
----------------------------------------------------------------
procedure Put_Error(
Message : in STRING
) is
begin
TIO.PUT_LINE(Error_File_Type, "Error : " & Message);
end Put_Error;
----------------------------------------------------------------
function Return_Code(
Severity : in Severity_Code
) return integer is
begin
case Severity is
when WARNING =>
return STL.STS_K_WARNING;
when SUCCESS =>
return STL.STS_K_SUCCESS;
when ERROR =>
return STL.STS_K_ERROR;
when INFORMATION =>
return STL.STS_K_INFO;
when SEVERE =>
return STL.STS_K_SEVERE;
end case;
end Return_Code;
----------------------------------------------------------------
procedure Invoke(
Process : in STRING;
Severity : out Severity_Code
) is
Stat : INTEGER;
Found : BOOLEAN := FALSE;
begin
for i in Process'range loop
if Process(i) /= ' ' and Process(i) /= ASCII.HT then
Found := TRUE;
exit;
end if;
end loop;
if not Found then
Severity := SUCCESS;
return;
end if;
Spawn(Stat, Process);
case Stat is
when STL.STS_K_WARNING =>
Severity := WARNING;
when STL.STS_K_SUCCESS =>
Severity := SUCCESS;
when STL.STS_K_ERROR =>
Severity := ERROR;
when STL.STS_K_INFO =>
Severity := INFORMATION;
when STL.STS_K_SEVERE =>
Severity := SEVERE;
when others =>
Severity := SEVERE;
end case;
end Invoke;
----------------------------------------------------------------
function Get_Item(
Item : in Item_Type;
Form : in Format := EDIT
) return STRING is
Line : STRING(1..Max_Arg_Length);
Len : INTEGER;
Stat : INTEGER;
Inx1 : INTEGER;
Inx2 : INTEGER;
Dev_Class : INTEGER;
begin
case Item is
when ARGUMENTS =>
Get_Foreign(Line);
if Form = EDIT then
return SU.Strip(Line);
else
return Line;
end if;
when USER_NAME | ACCOUNT | PROGRAM_NAME | PROCESS_MODE |
PROCESS_ID | TERMINAL_ADDRESS =>
Get_JPI(Item_Code => Item_Array(Item_Type'pos(Item)),
Out_String => Line,
Out_Len => SHORT_INTEGER(Len),
Status => Stat);
if Item = PROGRAM_NAME then
if Form = EDIT then
Inx1 := 0;
Inx2 := 0;
for i in 1 .. Len loop
if Line(i) = ']' then
Inx1 := i + 1;
for j in Inx1 .. Len loop
if Line(j) = '.' then
Inx2 := j - 1;
exit;
end if;
end loop;
exit;
end if;
end loop;
return Line(Inx1..Inx2);
else
return Line(1..Len);
end if;
else
while Len > 0 and then Line(Len) = ' ' loop
Len := Len - 1;
end loop;
return Line(1..Len);
end if;
when DEVICE_TYPE =>
return Terminal_Type'image(Get_Terminal_Type);
when others =>
return "";
end case;
end Get_Item;
----------------------------------------------------------------
function Read_No_Echo(
Address : in STRING := Get_Item(TERMINAL_ADDRESS)
) return STRING is
Line : STRING(1 .. 255);
Len : INTEGER;
Keyboard_File_Type : TIO.FILE_TYPE;
TT : SP.String_Type;
begin
SP.Mark;
if Address = "" then
TT := SP.Create("TT:");
else
TT := SP.Create(Address);
end if;
begin
TIO.OPEN(File => Keyboard_File_Type,
Mode => TIO.IN_FILE,
Name => SP.Value(TT),
Form => "CONNECT;TT_READ_NOECHO YES");
exception
when TIO.STATUS_ERROR =>
null;
when others =>
SP.Release;
raise;
end;
SP.Release;
TIO.GET_LINE(Keyboard_File_Type, Line, Len);
TIO.NEW_LINE(1);
return Line(1 .. Len);
end Read_No_Echo;
----------------------------------------------------------------
function Protection(
System : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
Owner : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
Group : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
World : in Protection_Specification :=
(Read=>YES, Write=>YES, Execute=>YES, Delete=>YES)
) return STRING is
Str : SP.String_Type;
begin
SP.Mark;
Str := SP.Create("");
Str := SP."&"(Str, Get_Protection_String("SYSTEM", System));
Str := SP."&"(Str, Get_Protection_String("OWNER", Owner));
Str := SP."&"(Str, Get_Protection_String("GROUP", Group));
Str := SP."&"(Str, Get_Protection_String("WORLD", World));
if SP.Length(Str) /= 0 then
Str := SP."&"("FILE;PROTECTION (",
SP.Substr(Str, 1, SP.Length(Str) - 1));
Str := SP."&"(Str, ")");
end if;
declare
Protection_String : STRING (1 .. SP.Length(Str));
begin
Protection_String := SP.Value(Str);
SP.Release;
return Protection_String;
end;
end Protection;
----------------------------------------------------------------
procedure Get_Time(
Value : out Time_Value
) is
Clock_Value : CAL.Time;
Year : CAL.Year_Number;
Month : CAL.Month_Number;
Day : CAL.Day_Number;
Duration : CAL.Day_Duration;
begin
Clock_Value := CAL.Clock;
CAL.Split(Clock_Value, Year, Month, Day, Duration);
Value.year := INTEGER(Year);
Value.month := INTEGER(Month);
Value.day := INTEGER(Day);
Value.time := INTEGER(Duration);
end Get_Time;
----------------------------------------------------------------
function "="(
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN is
begin
return Compare(Left, Right) = 0;
end "=";
----------------------------------------------------------------
function "<"(
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN is
begin
return Compare(Left, Right) < 0;
end "<";
----------------------------------------------------------------
function ">"(
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN is
begin
return Compare(Left, Right) > 0;
end ">";
----------------------------------------------------------------
function "<="(
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN is
begin
return Compare(Left, Right) <= 0;
end "<=";
----------------------------------------------------------------
function ">="(
Left : in Time_Value;
Right : in Time_Value
) return BOOLEAN is
begin
return Compare(Left, Right) >= 0;
end ">=";
----------------------------------------------------------------
function Date(
Value : in Time_Value
) return STRING is
begin
Check_Time_Value(Value);
return SU.Image(Value.month, 2, '0')
& '/'
& SU.Image(Value.day, 2, '0')
& '/'
& SU.Image((Value.year mod 100), 2, '0');
end Date;
----------------------------------------------------------------
function Calendar_Date(
Value : in Time_Value
) return STRING is
Index : INTEGER;
begin
Check_Time_Value(Value);
Index := Value.month;
return Month_Name(Index_Array(Index) .. Index_Array(Index + 1) - 1)
& INTEGER'image(Value.day)
& ','
& INTEGER'image(Value.year);
end Calendar_Date;
----------------------------------------------------------------
function Time(
Value : in Time_Value
) return STRING is
begin
Check_Time_Value(Value);
return SU.Image(Value.time / (60 * 60), 2, '0')
& ':'
& SU.Image((Value.time mod (60 * 60)) / 60, 2, '0')
& ':'
& SU.Image(Value.time mod 60, 2, '0');
end Time;
----------------------------------------------------------------
function Get_Terminal_Type
return Terminal_Type is
Line : STRING(1..Max_Arg_Length);
Len : INTEGER;
Stat : INTEGER;
Dev_Class : INTEGER;
begin
if Get_Item(TERMINAL_ADDRESS) = "" then
raise Terminal_Not_Attached;
end if;
Get_DVI(Item_Code => STL.DVI_DEVCLASS,
Dev_Name => Get_Item(TERMINAL_ADDRESS),
Out_Value => Len,
Out_String => Line,
Out_Len => SHORT_INTEGER(Len),
Status => Stat);
begin
Dev_Class := INTEGER'value(Line(1 .. Len));
exception
when CONSTRAINT_ERROR =>
raise Unknown_Terminal_Type;
end;
if Dev_Class = STL.DC_TERM or
Dev_Class = STL.DC_WORKSTATION then
Get_DVI(Item_Code => Item_Array(Item_Type'pos(DEVICE_TYPE)),
Dev_Name => Get_Item(TERMINAL_ADDRESS),
Out_Value => Len,
Out_String => Line,
Out_Len => SHORT_INTEGER(Len),
Status => Stat);
begin
if Dev_Class = STL.DC_TERM then
for i in Terminal_Type'first ..
Terminal_Type'val(Terminal_Type'pos(WORKSTATION) - 1)
loop
if INTEGER'value(Line(1 .. Len)) = Terminal_Array(i) then
return i;
end if;
end loop;
else
for i in Terminal_Type'val(Terminal_Type'pos(WORKSTATION) + 1) ..
Terminal_Type'last
loop
if INTEGER'value(Line(1 .. Len)) = Terminal_Array(i) then
return i;
end if;
end loop;
end if;
exception
when CONSTRAINT_ERROR =>
raise Unknown_Terminal_Type;
end;
end if;
raise Unknown_Terminal_Type;
end Get_Terminal_Type;
----------------------------------------------------------------
procedure Enable_Interrupt_Trap is
begin
case State is
when ENABLED =>
return;
when DISABLED =>
Disable_Control(Status => Status,
Mask => Control_Y,
Old_Mask => Save_Mask);
if not CD.Success(CD.Cond_Value_Type(Status)) then
Signal(CD.Cond_Value_Type(Status));
end if;
if INTEGER(Save_Mask and Control_Y) = 0 then
Enable_Control(Status => Status,
Mask => Save_Mask,
Old_Mask => Mask);
if not CD.Success(CD.Cond_Value_Type(Status)) then
Signal(CD.Cond_Value_Type(Status));
end if;
return;
end if;
when IGNORED =>
STL.Cancel(
Status => Condition,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
STL.Dassgn(
Status => Condition,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
end case;
STL.Assign(
Status => Condition,
Devnam => TT_Name,
Chan => TT_Channel);
if not CD.Success(Condition) then
Enable_Control(Status => Status,
Mask => Save_Mask,
Old_Mask => Mask);
if not CD.Success(CD.Cond_Value_Type(Status)) then
Signal(CD.Cond_Value_Type(Status));
end if;
end if;
STL.QIOW(
Status => Condition,
Chan => TT_Channel,
FUNC => STL.IO_SETMODE
or STL.IO_M_CtrlCAst
or STL.IO_M_CtrlYAst,
IOSB => IOSB,
P1 => TO_UNSIGNED_LONGWORD(Control_Character_Handler'Address));
if not CD.Success(Condition) then
STL.Dassgn(Status => Condition,
Chan => TT_Channel);
Enable_Control(Status => Status,
Mask => Save_Mask,
Old_Mask => Mask);
Signal(Condition);
end if;
State := ENABLED;
end Enable_Interrupt_Trap;
----------------------------------------------------------------
procedure Disable_Interrupt_Trap is
begin
case State is
when DISABLED =>
return;
when others =>
STL.Cancel(
Status => Condition,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
STL.Dassgn(
Status => Condition,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
Enable_Control(Status => Status,
Mask => Save_Mask,
Old_Mask => Mask);
if not CD.Success(CD.Cond_Value_Type(Status)) then
Signal(CD.Cond_Value_Type(Status));
end if;
State := DISABLED;
end case;
end Disable_Interrupt_Trap;
----------------------------------------------------------------
procedure Ignore_Interrupts is
begin
case State is
when IGNORED =>
return;
when DISABLED =>
Disable_Control(Status => Status,
Mask => Control_Y,
Old_Mask => Save_Mask);
if not CD.Success(CD.Cond_Value_Type(Status)) then
Signal(CD.Cond_Value_Type(Status));
end if;
if INTEGER(Save_Mask and Control_Y) = 0 then
Enable_Control(Status => Status,
Mask => Save_Mask,
Old_Mask => Mask);
if not CD.Success(CD.Cond_Value_Type(Status)) then
Signal(CD.Cond_Value_Type(Status));
end if;
return;
end if;
when ENABLED =>
STL.Cancel(
Status => Condition,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
STL.Dassgn(
Status => Condition,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
end case;
STL.Assign(Status => Condition,
Devnam => TT_Name,
Chan => TT_Channel);
if not CD.Success(Condition) then
Signal(Condition);
end if;
STL.QIOW(
Status => Condition,
Chan => TT_Channel,
FUNC => STL.IO_SETMODE
or STL.IO_M_CtrlCAst
or STL.IO_M_CtrlYAst,
IOSB => IOSB,
P1 => TO_UNSIGNED_LONGWORD(Control_Character_Ignore'Address));
if not CD.Success(Condition) then
Signal(Condition);
end if;
State := IGNORED;
Ignored_State := FALSE;
end Ignore_Interrupts;
----------------------------------------------------------------
function Interrupts_Ignored
return BOOLEAN is
begin
return Get_Interrupt_State = IGNORED and Ignored_State;
end Interrupts_Ignored;
----------------------------------------------------------------
procedure Set_Interrupt_State(
State : in Interrupt_State
) is
begin
if State = Get_Interrupt_State then
return;
end if;
case State is
when ENABLED =>
Enable_Interrupt_Trap;
when DISABLED =>
Disable_Interrupt_Trap;
when IGNORED =>
Ignore_Interrupts;
end case;
end Set_Interrupt_State;
----------------------------------------------------------------
function Get_Interrupt_State
return Interrupt_State is
begin
return State;
end Get_Interrupt_State;
----------------------------------------------------------------
begin
State := DISABLED;
Ignored_State := FALSE;
Error_Switch := 0;
TIO.OPEN(File => Error_File_Type,
Mode => TIO.OUT_FILE,
Name => "SYS$ERROR",
Form => "CONNECT;END_OF_FILE YES");
exception
when TIO.NAME_ERROR =>
TIO.CREATE(File => Error_File_Type,
Mode => TIO.OUT_FILE,
Name => "SYS$ERROR",
Form => "CONNECT;END_OF_FILE YES");
when TIO.STATUS_ERROR =>
null;
end Host_Lib;
pragma page;
--::::::::::
--string.spc
--::::::::::
-- $Source: /nosc/work/abstractions/string/RCS/string.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:51:46 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/string/RCS/string.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:51:46 $ -- $Author: ron $
package string_pkg is
--| Overview:
--| Package string_pkg exports an abstract data type, string_type. A
--| string_type value is a sequence of characters. The values have arbitrary
--| length. For a value, s, with length, l, the individual characters are
--| numbered from 1 to l. These values are immutable; characters cannot be
--| replaced or appended in a destructive fashion.
--|
--| In the documentation for this package, we are careful to distinguish
--| between string_type objects, which are Ada objects in the usual sense,
--| and string_type values, the members of this data abstraction as described
--| above. A string_type value is said to be associated with, or bound to,
--| a string_type object after an assignment (:=) operation.
--|
--| The operations provided in this package fall into three categories:
--|
--| 1. Constructors: These functions typically take one or more string_type
--| objects as arguments. They work with the values associated with
--| these objects, and return new string_type values according to
--| specification. By a slight abuse of language, we will sometimes
--| coerce from string_type objects to values for ease in description.
--|
--| 2. Heap Management:
--| These operations (make_persistent, flush, mark, release) control the
--| management of heap space. Because string_type values are
--| allocated on the heap, and the type is not limited, it is necessary
--| for a user to assume some responsibility for garbage collection.
--| String_type is not limited because of the convenience of
--| the assignment operation, and the usefulness of being able to
--| instantiate generic units that contain private type formals.
--| ** Important: To use this package properly, it is necessary to read
--| the descriptions of the operations in this section.
--|
--| 3. Queries: These functions return information about the values
--| that are associated with the argument objects. The same conventions
--| for description of operations used in (1) is adopted.
--|
--| A note about design decisions... The decision to not make the type
--| limited causes two operations to be carried over from the representation.
--| These are the assignment operation, :=, and the "equality" operator, "=".
--| See the discussion at the beginning of the Heap Management section for a
--| discussion of :=.
--| See the spec for the first of the equal functions for a discussion of "=".
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec. Overloaded subprograms are followed
--| by (n), where n is the number of subprograms of that name.
--|
--| 1. Constructors:
--| create
--| "&" (3)
--| substr
--| splice
--| insert (3)
--| lower (2)
--| upper (2)
--| 2. Heap Management:
--| make_persistent (2)
--| flush
--| mark, release
--| 3. Queries:
--| is_empty
--| length
--| value
--| fetch
--| set_comparison_option
--| get_comparison_option
--| equal (3)
--| "<" (3),
--| "<=" (3)
--| match_c
--| match_not_c
--| match_s (2)
--| match_any (2)
--| match_none (2)
--| Notes:
--| Programmer: Ron Kownacki
type string_type is private;
bounds: exception; --| Raised on index out of bounds.
any_empty: exception; --| Raised on incorrect use of match_any.
illegal_alloc: exception; --| Raised by value creating operations.
illegal_dealloc: exception; --| Raised by release.
-- Constructors:
function create(s: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value consisting of the sequence of characters in s.
--| Sometimes useful for array or record aggregates.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function "&"(s1, s2: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return the concatenation of s1 and s2.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function "&"(s1: string_type; s2: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return the concatenation of s1 and create(s2).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function "&"(s1: string; s2: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return the concatenation of create(s1) and s2.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function substr(s: string_type; i: positive; len: natural)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return the substring, of specified length, that occurs in s at
--| position i. If len = 0, then returns the empty value.
--| Otherwise, raises bounds if either i or (i + len - 1)
--| is not in 1..length(s).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function splice(s: string_type; i: positive; len: natural)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Let s be the string, abc, where a, b and c are substrings. If
--| substr(s, i, length(b)) = b, for some i in 1..length(s), then
--| splice(s, i, length(b)) = ac.
--| Returns a value equal to s if len = 0. Otherwise, raises bounds if
--| either i or (i + len - 1) is not in 1..length(s).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function insert(s1, s2: string_type; i: positive)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return substr(s1, 1, i - 1) & s2 & substr(s1, i, length(s1)).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in 1..length(s1) + 1.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function insert(s1: string_type; s2: string; i: positive)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return substr(s1, 1, i - 1) & s2 & substr(s1, i, length(s1)).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in 1..length(s1) + 1.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function insert(s1: string; s2: string_type; i: positive)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return s1(s1'first..i - 1) & s2 & s1(i..s1'last).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in s'first..s'last + 1.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function lower(s: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that contains exactly those characters in s with
--| the exception that all upper case characters are replaced by their
--| lower case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function lower(s: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that is a copy of s with the exception that all
--| upper case characters are replaced by their lower case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function upper(s: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that contains exactly those characters in s with
--| the exception that all lower case characters are replaced by their
--| upper case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function upper(s: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that is a copy of s with the exception that all
--| lower case characters are replaced by their upper case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
-- Heap Management (including object/value binding):
--
-- Two forms of heap management are provided. The general scheme is to "mark"
-- the current state of heap usage, and to "release" in order to reclaim all
-- space that has been used since the last mark. However, this alone is
-- insufficient because it is frequently desirable for objects to remain
-- associated with values for longer periods of time, and this may come into
-- conflict with the need to clean up after a period of "string hacking."
-- To deal with this problem, we introduce the notions of "persistent" and
-- "nonpersistent" values.
--
-- The nonpersistent values are those that are generated by the constructors
-- in the previous section. These are claimed by the release procedure.
-- Persistent values are generated by the two make_persistent functions
-- described below. These values must be disposed of individually by means of
-- the flush procedure.
--
-- This allows a description of the meaning of the ":=" operation. For a
-- statement of the form, s := expr, where expr is a string_type expression,
-- the result is that the value denoted/created by expr becomes bound to the
-- the object, s. Assignment in no way affects the persistence of the value.
-- If expr happens to be an object, then the value associated with it will be
-- shared. Ideally, this sharing would not be visible, since values are
-- immutable. However, the sharing may be visible because of the memory
-- management, as described below. Programs which depend on such sharing are
-- erroneous.
function make_persistent(s: string_type)
return string_type;
--| Effects:
--| Returns a persistent value, v, containing exactly those characters in
--| value(s). The value v will not be claimed by any subsequent release.
--| Only an invocation of flush will claim v. After such a claiming
--| invocation of flush, the use (other than :=) of any other object to
--| which v was bound is erroneous, and program_error may be raised for
--| such a use.
function make_persistent(s: string)
return string_type;
--| Effects:
--| Returns a persistent value, v, containing exactly those chars in s.
--| The value v will not be claimed by any subsequent release.
--| Only an invocation of flush will reclaim v. After such a claiming
--| invocation of flush, the use (other than :=) of any other object to
--| which v was bound is erroneous, and program_error may be raised for
--| such a use.
procedure flush(s: in out string_type);
--| Effects:
--| Return heap space used by the value associated with s, if any, to
--| the heap. s becomes associated with the empty value. After an
--| invocation of flush claims the value, v, then any use (other than :=)
--| of an object to which v was bound is erroneous, and program_error
--| may be raised for such a use.
--|
--| This operation should be used only for persistent values. The mark
--| and release operations are used to deallocate space consumed by other
--| values. For example, flushing a nonpersistent value implies that a
--| release that tries to claim this value will be erroneous, and
--| program_error may be raised for such a use.
procedure mark;
--| Effects:
--| Marks the current state of heap usage for use by release.
--| An implicit mark is performed at the beginning of program execution.
procedure release;
--| Raises: illegal_dealloc
--| Effects:
--| Releases all heap space used by nonpersistent values that have been
--| allocated since the last mark. The values that are claimed include
--| those bound to objects as well as those produced and discarded during
--| the course of general "string hacking." If an invocation of release
--| claims a value, v, then any subsequent use (other than :=) of any
--| other object to which v is bound is erroneous, and program_error may
--| be raised for such a use.
--|
--| Raises illegal_dealloc if the invocation of release does not balance
--| an invocation of mark. It is permissible to match the implicit
--| initial invocation of mark. However, subsequent invocations of
--| constructors will raise the illegal_alloc exception until an
--| additional mark is performed. (Anyway, there is no good reason to
--| do this.) In any case, a number of releases matching the number of
--| currently active marks is implicitly performed at the end of program
--| execution.
--|
--| Good citizens generally perform their own marks and releases
--| explicitly. Extensive string hacking without cleaning up will
--| cause your program to run very slowly, since the heap manager will
--| be forced to look hard for chunks of space to allocate.
-- Queries:
function is_empty(s: string_type)
return boolean;
--| Effects:
--| Return true iff s is the empty sequence of characters.
function length(s: string_type)
return natural;
--| Effects:
--| Return number of characters in s.
function value(s: string_type)
return string;
--| Effects:
--| Return a string, s2, that contains the same characters that s
--| contains. The properties, s2'first = 1 and s2'last = length(s),
--| are satisfied. This implies that, for a given string, s3,
--| value(create(s3))'first may not equal s3'first, even though
--| value(create(s3)) = s3 holds. Thus, "content equality" applies
--| although the string objects may be distinguished by the use of
--| the array attributes.
function fetch(s: string_type; i: positive)
return character;
--| Raises: bounds
--| Effects:
--| Return the ith character in s. Characters are numbered from
--| 1 to length(s). Raises bounds if i not in 1..length(s).
type comparison_option is (case_sensitive, case_insensitive);
--| Used for equal, "<" and "<=" functions. If the comparison_option
--| is case_sensitive, then a straightforward comparison of values
--| is performed. If the option is case_insensitive, then comparison
--| between the arguments is performed after first normalizing them to
--| lower case.
procedure set_comparison_option(choice: comparison_option);
--| Effects:
--| Set the comparison option for equal, "<" and "<=" (as described
--| above) to the given choice. The initial setting is case_sensitive.
function get_comparison_option
return comparison_option;
--| Effects:
--| Return the current comparison_option setting.
function equal(s1, s2: string_type)
return boolean;
--| Effects:
--| Value equality relation; return true iff length(s1) = length(s2)
--| and, for all i in 1..length(s1), fetch(s1, i) = fetch(s2, i).
--| (If the comparison_option is currently case_insensitive, then
--| lower(s1) and lower(s2) are used instead.)
--|
--| Notes:
--| The "=" operation is carried over from the representation.
--| It allows one to distinguish among the heap addresses of
--| string_type values. Even "equal" values under case_sensitive
--| comparison may not be "=", although s1 = s2 implies equal(s1, s2).
--| There is no reason to use "=".
function equal(s1: string_type; s2: string)
return boolean;
--| Effects:
--| Return equal(s1, create(s2)).
function equal(s1: string; s2: string_type)
return boolean;
--| Effects:
--| Return equal(create(s1), s2).
function "<"(s1, s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) < value(s2).
function "<"(s1: string_type; s2: string)
return boolean;
--| Effects:
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) < s2.
function "<"(s1: string; s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison according to the current comparison_option;
--| return s1 < value(s2).
function "<="(s1, s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) <= value(s2).
function "<="(s1: string_type; s2: string)
return boolean;
--| Effects:
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) <= s2.
function "<="(s1: string; s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison according to the current comparison_option;
--| return s1 <= value(s2).
function match_c(s: string_type; c: character; start: positive := 1)
return natural;
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) = c. Returns 0 if no such i exists,
--| including the case where is_empty(s).
function match_not_c(s: string_type; c: character; start: positive := 1)
return natural;
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= c. Returns 0 if no such i exists,
--| including the case where is_empty(s).
function match_s(s1, s2: string_type; start: positive := 1)
return natural;
--| Effects:
--| Return the minimum index, i, in start..length(s1), such that,
--| for all j in 1..length(s2), fetch(s2, j) = fetch(s1, i + j - 1).
--| This is the position of the substring, s2, in s1.
--| Returns 0 if no such i exists, including the cases
--| where is_empty(s1) or is_empty(s2).
--| Note that equal(substr(s1, match_s(s1, s2, i), length(s2)), s2)
--| holds, providing that match_s does not raise an exception.
function match_s(s1: string_type; s2: string; start: positive := 1)
return natural;
--| Effects:
--| Return the minimum index, i, in start..length(s1), such that,
--| for all j in s2'range, s2(j) = fetch(s1, i + j - 1).
--| This is the position of the substring, s2, in s1.
--| Returns 0 if no such i exists, including the cases
--| where is_empty(s1) or s2 = "".
--| Note that equal(substr(s1, match_s(s1, s2, i), s2'length), s2)
--| holds, providing that match_s does not raise an exception.
function match_any(s, any: string_type; start: positive := 1)
return natural;
--| Raises: any_empty
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) = fetch(any, j), for some j in 1..length(any).
--| Raises any_empty if is_empty(any).
--| Otherwise, returns 0 if no such i exists, including the case
--| where is_empty(s).
function match_any(s: string_type; any: string; start: positive := 1)
return natural;
--| Raises: any_empty
--| Effects:
--| Return the minimum index, i, in start..length(s), such that
--| fetch(s, i) = any(j), for some j in any'range.
--| Raises any_empty if any = "".
--| Otherwise, returns 0 if no such i exists, including the case
--| where is_empty(s).
function match_none(s, none: string_type; start: positive := 1)
return natural;
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= fetch(none, j) for each j in 1..length(none).
--| If (not is_empty(s)) and is_empty(none), then i is 1.
--| Returns 0 if no such i exists, including the case
--| where is_empty(s).
function match_none(s: string_type; none: string; start: positive := 1)
return natural;
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= none(j) for each j in none'range.
--| If not is_empty(s) and none = "", then i is 1.
--| Returns 0 if no such i exists, including the case
--| where is_empty(s).
private
type string_type is access string;
--| Abstract data type, string_type, is a constant sequence of chars
--| of arbitrary length. Representation type is access string.
--| It is important to distinguish between an object of the rep type
--| and its value; for an object, r, val(r) denotes the value.
--|
--| Representation Invariant: I: rep --> boolean
--| I(r: rep) = (val(r) = null) or else
--| (val(r).all'first = 1 &
--| val(r).all'last >= 0 &
--| (for all r2, val(r) = val(r2) /= null => r is r2))
--|
--| Abstraction Function: A: rep --> string_type
--| A(r: rep) = if r = null then
--| the empty sequence
--| elsif r'last = 0 then
--| the empty sequence
--| else
--| the sequence consisting of r(1),...,r(r'last).
end string_pkg;
--::::::::::
--string.bdy
--::::::::::
-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $
with unchecked_deallocation;
with lists, stack_pkg;
with case_insensitive_string_comparison;
package body string_pkg is
--| Overview:
--| The implementation for most operations is fairly straightforward.
--| The interesting aspects involve the allocation and deallocation of
--| heap space. This is done as follows:
--|
--| 1. A stack of accesses to lists of string_type values is set up
--| so that the top of the stack always refers to a list of values
--| that were allocated since the last invocation of mark.
--| The stack is called scopes, referring to the dynamic scopes
--| defined by the invocations of mark and release.
--| There is an implicit invocation of mark when the
--| package body is elaborated; this is implemented with an explicit
--| invocation in the package initialization code.
--|
--| 2. At each invocation of mark, a pointer to an empty list
--| is pushed onto the stack.
--|
--| 3. At each invocation of release, all of the values in the
--| list referred to by the pointer at the top of the stack are
--| returned to the heap. Then the list, and the pointer to it,
--| are returned to the heap. Finally, the stack is popped.
package CISC renames case_insensitive_string_comparison;
package string_list_pkg is new lists(string_type);
subtype string_list is string_list_pkg.list;
type string_list_ptr is access string_list;
package scope_stack_pkg is new stack_pkg(string_list_ptr);
subtype scope_stack is scope_stack_pkg.stack;
use string_list_pkg;
use scope_stack_pkg;
scopes: scope_stack; -- See package body overview.
current_comparison_option: comparison_option := case_sensitive;
-- Utility functions/procedures:
function enter(s: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Stores s, the address of s.all, in current scope list (top(scopes)),
--| and returns s. Useful for functions that create and return new
--| string_type values.
--| Raises illegal_alloc if the scopes stack is empty.
function string_lower(s: string)
return string;
--| Effects:
--| Return a string with the same bounds and contents as s, with the
--| exception that all upper case characters are replaced with their
--| lower case counterparts.
function string_upper(s: string)
return string;
--| Effects:
--| Return a string with the same bounds and contents as s, with the
--| exception that all lower case characters are replaced with their
--| upper case counterparts.
function string_equal(s1, s2: string)
return boolean;
--| Effects:
--| If current_comparison_option = case_sensitive, then return
--| (s1 = s2); otherwise, return string_lower(s1) = string_lower(s2).
function string_less(s1, s2: string)
return boolean;
--| Effects:
--| If current_comparison_option = case_sensitive, then return
--| (s1 < s2); otherwise, return string_lower(s1) < string_lower(s2).
function string_less_or_equal(s1, s2: string)
return boolean;
--| Effects:
--| If current_comparison_option = case_sensitive, then return
--| (s1 <= s2); otherwise, return string_lower(s1) <= string_lower(s2).
function match_string(s1, s2: string; start: positive := 1)
return natural;
--| Raises: no_match
--| Effects:
--| Returns the minimum index, i, in s1'range such that
--| s1(i..i + s2'length - 1) = s2. Returns 0 if no such index.
--| Requires:
--| s1'first = 1.
-- Constructors:
function create(s: string)
return string_type is
subtype constr_str is string(1..s'length);
dec_s: constr_str := s;
begin
return enter(new constr_str'(dec_s));
end create;
function "&"(s1, s2: string_type)
return string_type is
begin
if is_empty(s1) then return enter(make_persistent(s2)); end if;
if is_empty(s2) then return enter(make_persistent(s1)); end if;
return create(s1.all & s2.all);
end "&";
function "&"(s1: string_type; s2: string)
return string_type is
begin
if s1 = null then return create(s2); end if;
return create(s1.all & s2);
end "&";
function "&"(s1: string; s2: string_type)
return string_type is
begin
if s2 = null then return create(s1); end if;
return create(s1 & s2.all);
end "&";
function substr(s: string_type; i: positive; len: natural)
return string_type is
begin
if len = 0 then return null; end if;
return create(s(i..(i + len - 1)));
exception
when constraint_error => -- on array fetch or null deref
raise bounds;
end substr;
function splice(s: string_type; i: positive; len: natural)
return string_type is
begin
if len = 0 then return enter(make_persistent(s)); end if;
if i + len - 1 > length(s) then raise bounds; end if;
return create(s(1..(i - 1)) & s((i + len)..length(s)));
end splice;
function insert(s1, s2: string_type; i: positive)
return string_type is
begin
if i > length(s1) + 1 then raise bounds; end if;
if s1 = null then return create(value(s2)); end if;
if s2 = null then return create(s1.all); end if;
return create(s1(1..(i - 1)) & s2.all & s1(i..s1'last));
end insert;
function insert(s1: string_type; s2: string; i: positive)
return string_type is
begin
if i > length(s1) + 1 then raise bounds; end if;
if s1 = null then return create(s2); end if;
return create(s1(1..(i - 1)) & s2 & s1(i..s1'last));
end insert;
function insert(s1: string; s2: string_type; i: positive)
return string_type is
begin
if i not in s1'first..s1'last + 1 then raise bounds; end if;
if s2 = null then return create(s1); end if;
return create(s1(s1'first..(i - 1)) & s2.all & s1(i..s1'last));
end insert;
function lower(s: string)
return string_type is
begin
return create(string_lower(s));
end lower;
function lower(s: string_type)
return string_type is
begin
if s = null then return null; end if;
return create(string_lower(s.all));
end lower;
function upper(s: string)
return string_type is
begin
return create(string_upper(s));
end upper;
function upper(s: string_type)
return string_type is
begin
if s = null then return null; end if;
return create(string_upper(s.all));
end upper;
-- Heap Management:
function make_persistent(s: string_type)
return string_type is
subtype constr_str is string(1..length(s));
begin
if s = null or else s.all = "" then return null;
else return new constr_str'(s.all);
end if;
end make_persistent;
function make_persistent(s: string)
return string_type is
subtype constr_str is string(1..s'length);
dec_s: constr_str := s;
begin
if dec_s = "" then return null;
else return new constr_str'(dec_s); end if;
end make_persistent;
procedure real_flush is new unchecked_deallocation(string,
string_type);
--| Effect:
--| Return space used by argument to heap. Does nothing if null.
--| Notes:
--| This procedure is actually the body for the flush procedure,
--| but a generic instantiation cannot be used as a body for another
--| procedure. You tell me why.
procedure flush(s: in out string_type) is
begin
if s /= null then real_flush(s); end if;
-- Actually, the if isn't needed; however, DECada compiler chokes
-- on deallocation of null.
end flush;
procedure mark is
begin
push(scopes, new string_list'(create));
end mark;
procedure release is
procedure flush_list_ptr is
new unchecked_deallocation(string_list, string_list_ptr);
iter: string_list_pkg.ListIter;
top_list: string_list_ptr;
s: string_type;
begin
pop(scopes, top_list);
iter := MakeListIter(top_list.all);
while more(iter) loop
next(iter, s);
flush(s); -- real_flush is bad, DECada bug
-- real_flush(s);
end loop;
destroy(top_list.all);
flush_list_ptr(top_list);
exception
when empty_stack =>
raise illegal_dealloc;
end release;
-- Queries:
function is_empty(s: string_type)
return boolean is
begin
return (s = null) or else (s.all = "");
end is_empty;
function length(s: string_type)
return natural is
begin
if s = null then return 0; end if;
return(s.all'length);
end length;
function value(s: string_type)
return string is
subtype null_range is positive range 1..0;
subtype null_string is string(null_range);
begin
if s = null then return null_string'(""); end if;
return s.all;
end value;
function fetch(s: string_type; i: positive)
return character is
begin
if is_empty(s) or else (i not in s'range) then raise bounds; end if;
return s(i);
end fetch;
procedure set_comparison_option(choice: comparison_option) is
begin
current_comparison_option := choice;
end set_comparison_option;
function get_comparison_option
return comparison_option is
begin
return current_comparison_option;
end get_comparison_option;
function equal(s1, s2: string_type)
return boolean is
begin
if is_empty(s1) then return is_empty(s2); end if;
return (s2 /= null) and then string_equal(s1.all, s2.all);
end equal;
function equal(s1: string_type; s2: string)
return boolean is
begin
if s1 = null then return s2 = ""; end if;
return string_equal(s1.all, s2);
end equal;
function equal(s1: string; s2: string_type)
return boolean is
begin
if s2 = null then return s1 = ""; end if;
return string_equal(s1, s2.all);
end equal;
function "<"(s1, s2: string_type)
return boolean is
begin
if is_empty(s1) then
return (not is_empty(s2));
else
return (s1.all < s2);
end if;
end "<";
function "<"(s1: string_type; s2: string)
return boolean is
begin
if s1 = null then return s2 /= ""; end if;
return string_less(s1.all, s2);
end "<";
function "<"(s1: string; s2: string_type)
return boolean is
begin
if s2 = null then return false; end if;
return string_less(s1, s2.all);
end "<";
function "<="(s1, s2: string_type)
return boolean is
begin
if is_empty(s1) then return true; end if;
return (s1.all <= s2);
end "<=";
function "<="(s1: string_type; s2: string)
return boolean is
begin
if s1 = null then return true; end if;
return string_less_or_equal(s1.all, s2);
end "<=";
function "<="(s1: string; s2: string_type)
return boolean is
begin
if s2 = null then return s1 = ""; end if;
return string_less_or_equal(s1, s2.all);
end "<=";
function match_c(s: string_type; c: character; start: positive := 1)
return natural is
begin
if s = null then return 0; end if;
for i in start..s.all'last loop
if s(i) = c then
return i;
end if;
end loop;
return 0;
end match_c;
function match_not_c(s: string_type; c: character; start: positive := 1)
return natural is
begin
if s = null then return 0; end if;
for i in start..s.all'last loop
if s(i) /= c then
return i;
end if;
end loop;
return 0;
end match_not_c;
function match_s(s1, s2: string_type; start: positive := 1)
return natural is
begin
if (s1 = null) or else (s2 = null) then return 0; end if;
return match_string(s1.all, s2.all, start);
end match_s;
function match_s(s1: string_type; s2: string; start: positive := 1)
return natural is
begin
if s1 = null then return 0; end if;
return match_string(s1.all, s2, start);
end match_s;
function match_any(s, any: string_type; start: positive := 1)
return natural is
begin
if any = null then raise any_empty; end if;
return match_any(s, any.all, start);
end match_any;
function match_any(s: string_type; any: string; start: positive := 1)
return natural is
begin
if any = "" then raise any_empty; end if;
if s = null then return 0; end if;
for i in start..s.all'last loop
for j in any'range loop
if s(i) = any(j) then
return i;
end if;
end loop;
end loop;
return 0;
end match_any;
function match_none(s, none: string_type; start: positive := 1)
return natural is
begin
if is_empty(s) then return 0; end if;
if is_empty(none) then return 1; end if;
return match_none(s, none.all, start);
end match_none;
function match_none(s: string_type; none: string; start: positive := 1)
return natural is
found: boolean;
begin
if is_empty(s) then return 0; end if;
for i in start..s.all'last loop
found := true;
for j in none'range loop
if s(i) = none(j) then
found := false;
exit;
end if;
end loop;
if found then return i; end if;
end loop;
return 0;
end match_none;
-- Utilities:
function enter(s: string_type)
return string_type is
begin
top(scopes).all := attach(top(scopes).all, s);
return s;
exception
when empty_stack =>
raise illegal_alloc;
end enter;
function string_lower(s: string)
return string is
begin
return CISC.downCase(S);
end string_lower;
function string_upper(s: string)
return string is
begin
return CISC.upCase(S);
end string_upper;
function string_equal(s1, s2: string)
return boolean is
begin
if current_comparison_option = case_sensitive then
return s1 = s2;
else
return CISC.equal(S1, S2);
end if;
end string_equal;
function string_less(s1, s2: string)
return boolean is
begin
if current_comparison_option = case_sensitive then
return s1 < s2;
else
return CISC.less(S1, S2);
end if;
end string_less;
function string_less_or_equal(s1, s2: string)
return boolean is
begin
if current_comparison_option = case_sensitive then
return s1 <= s2;
else
return CISC.less_or_equal(S1, S2);
end if;
end string_less_or_equal;
function match_string(s1, s2: string; start: positive := 1)
return natural is
offset: natural;
begin
offset := s2'length - 1;
for i in start..(s1'last - offset) loop
if s1(i..(i + offset)) = s2 then
return i;
end if;
end loop;
return 0;
exception when constraint_error => -- on offset := s2'length (= 0)
return 0;
end match_string;
begin -- Initialize the scopes stack with an implicit mark.
scopes := create;
mark;
end string_pkg;
--::::::::::
--slists.spc
--::::::::::
with String_Pkg;
with Lists;
package String_Lists is new Lists(
ItemType => String_Pkg.String_Type,
Equal => String_Pkg.Equal);
--::::::::::
--ilists.spc
--::::::::::
with Lists;
package Integer_Lists is new Lists(
ItemType => INTEGER);
--::::::::::
--lists.spc
--::::::::::
generic
type ItemType is private; --| This is the data being manipulated.
with function Equal ( X,Y: in ItemType) return boolean is "=";
--| This allows the user to define
--| equality on ItemType. For instance
--| if ItemType is an abstract type
--| then equality is defined in terms of
--| the abstract type. If this function
--| is not provided equality defaults to
--| =.
package Lists is
--| This package provides singly linked lists with elements of type
--| ItemType, where ItemType is specified by a generic parameter.
--| Overview
--| When this package is instantiated, it provides a linked list type for
--| lists of objects of type ItemType, which can be any desired type. A
--| complete set of operations for manipulation, and releasing
--| those lists is also provided. For instance, to make lists of strings,
--| all that is necessary is:
--|
--| type StringType is string(1..10);
--|
--| package Str_List is new Lists(StringType); use Str_List;
--|
--| L:List;
--| S:StringType;
--|
--| Then to add a string S, to the list L, all that is necessary is
--|
--| L := Create;
--| Attach(S,L);
--|
--|
--| This package provides basic list operations.
--|
--| Attach append an object to an object, an object to a list,
--| or a list to an object, or a list to a list.
--| Copy copy a list using := on elements
--| CopyDeep copy a list by copying the elements using a copy
--| operation provided by the user
--| Create Creates an empty list
--| DeleteHead removes the head of a list
--| DeleteItem delete the first occurrence of an element from a list
--| DeleteItems delete all occurrences of an element from a list
--| Destroy remove a list
--| DestroyDeep destroy a list as well as the elements in that list
--| Equal are two lists equal
--| FirstValue get the information from the first element of a list
--| Forward advances an iterator
--| IsInList determines whether a given element is in a given list
--| IsEmpty returns true if the list is empty
--| LastValue return the last value of a list
--| Length Returns the length of a list
--| MakeList this takes a single element and returns a list
--| MakeListIter prepares for an iteration over a list
--| More are there any more items in the list
--| Next get the next item in a list
--| ReplaceHead replace the information at the head of the list
--| ReplaceTail replace the tail of a list with a new list
--| Tail get the tail of a list
--| CellValue this takes an iterator and returns the value of the element
--| whose position the iterator holds
--|
--| N/A: Effects, Requires, Modifies, and Raises.
--| Notes
--| Programmer Buddy Altus
--| Types
--| -----
type List is private;
type ListIter is private;
--| Exceptions
--| ----------
CircularList :exception; --| Raised if an attemp is made to
--| create a circular list. This
--| results when a list is attempted
--| to be attached to itself.
EmptyList :exception; --| Raised if an attemp is made to
--| manipulate an empty list.
ItemNotPresent :exception; --| Raised if an attempt is made to
--| remove an element from a list in
--| which it does not exist.
NoMore :exception; --| Raised if an attemp is made to
--| get the next element from a list
--| after iteration is complete.
--| Operations
--| ----------
----------------------------------------------------------------------------
procedure Attach( --| appends List2 to List1
List1: in out List; --| The list being appended to.
List2: in List --| The list being appended.
);
--| Raises
--| CircularList
--| Effects
--| Appends List1 to List2. This makes the next field of the last element
--| of List1 refer to List2. This can possibly change the value of List1
--| if List1 is an empty list. This causes sharing of lists. Thus if
--| user Destroys List1 then List2 will be a dangling reference.
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
--| Modifies
--| Changes the next field of the last element in List1 to be List2.
-------------------------------------------------------------------------------
function Attach( --| Creates a new list containing the two
--| Elements.
Element1: in ItemType; --| This will be first element in list.
Element2: in ItemType --| This will be second element in list.
) return List;
--| Effects
--| This creates a list containing the two elements in the order
--| specified.
-------------------------------------------------------------------------------
procedure Attach( --| List L is appended with Element.
L: in out List; --| List being appended to.
Element: in ItemType --| This will be last element in l ist.
);
--| Effects
--| Appends Element onto the end of the list L. If L is empty then this
--| may change the value of L.
--|
--| Modifies
--| This appends List L with Element by changing the next field in List.
--------------------------------------------------------------------------------
procedure Attach( --| Makes Element first item in list L.
Element: in ItemType; --| This will be the first element in list.
L: in out List --| The List which Element is being
--| prepended to.
);
--| Effects
--| This prepends list L with Element.
--|
--| Modifies
--| This modifies the list L.
--------------------------------------------------------------------------
function Attach ( --| attaches two lists
List1: in List; --| first list
List2: in List --| second list
) return List;
--| Raises
--| CircularList
--| Effects
--| This returns a list which is List1 attached to List2. If it is desired
--| to make List1 be the new attached list the following ada code should be
--| used.
--|
--| List1 := Attach (List1, List2);
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
-------------------------------------------------------------------------
function Attach ( --| prepends an element onto a list
Element: in ItemType; --| element being prepended to list
L: in List --| List which element is being added
--| to
) return List;
--| Effects
--| Returns a new list which is headed by Element and followed by L.
------------------------------------------------------------------------
function Attach ( --| Adds an element to the end of a list
L: in List; --| The list which element is being added to.
Element: in ItemType --| The element being added to the end of
--| the list.
) return List;
--| Effects
--| Returns a new list which is L followed by Element.
--------------------------------------------------------------------------
function Copy( --| returns a copy of list1
L: in List --| list being copied
) return List;
--| Effects
--| Returns a copy of L.
--------------------------------------------------------------------------
generic
with function Copy(I: in ItemType) return ItemType;
function CopyDeep( --| returns a copy of list using a user supplied
--| copy function. This is helpful if the type
--| of a list is an abstract data type.
L: in List --| List being copied.
) return List;
--| Effects
--| This produces a new list whose elements have been duplicated using
--| the Copy function provided by the user.
------------------------------------------------------------------------------
function Create --| Returns an empty List
return List;
------------------------------------------------------------------------------
procedure DeleteHead( --| Remove the head element from a list.
L: in out List --| The list whose head is being removed.
);
--| RAISES
--| EmptyList
--|
--| EFFECTS
--| This will return the space occupied by the first element in the list
--| to the heap. If sharing exists between lists this procedure
--| could leave a dangling reference. If L is empty EmptyList will be
--| raised.
------------------------------------------------------------------------------
procedure DeleteItem( --| remove the first occurrence of Element
--| from L
L: in out List; --| list element is being removed from
Element: in ItemType --| element being removed
);
--| EFFECTS
--| Removes the first element of the list equal to Element. If there is
--| not an element equal to Element than ItemNotPresent is raised.
--| MODIFIES
--| This operation is destructive, it returns the storage occupied by
--| the elements being deleted.
----------------------------------------------------------------------------
function DeleteItem( --| remove the first occurrence of Element
--| from L
L: in List; --| list element is being removed from
Element: in ItemType --| element being removed
) return List;
--| EFFECTS
--| This returns the List L with the first occurrence of Element removed.
------------------------------------------------------------------------------
function DeleteItems ( --| remove all occurrences of Element
--| from L.
L: in List; --| The List element is being removed from
Element: in ItemType --| element being removed
) return List;
--| EFFECTS
--| This function returns a copy of the list L which has all elements which
--| have value Element removed.
-------------------------------------------------------------------------------
procedure DeleteItems ( --| remove all occurrences of Element
--| from L.
L: in out List; --| The List element is being removed from
Element: in ItemType --| element being removed
);
--| EFFECTS
--| This procedure removes all occurrences of Element from the List L. This
--| is a destructive procedure.
------------------------------------------------------------------------------
procedure Destroy ( --| removes the list
L: in out List --| the list being removed
);
--| Effects
--| This returns to the heap all the storage that a list occupies. Keep in
--| mind if there exists sharing between lists then this operation can leave
--| dangling references.
------------------------------------------------------------------------------
generic
with procedure Dispose (I :in out ItemType);
procedure DestroyDeep ( --| Destroy a list as well as all objects which
--| comprise an element of the list.
L :in out List
);
--| OVERVIEW
--| This procedure is used to destroy a list and all the objects contained
--| in an element of the list. For example if L is a list of lists
--| then destroy L does not destroy the lists which are elements of L.
--| DestroyDeep will now destroy L and all the objects in the elements of L.
--| The produce Dispose is a procedure which will destroy the objects which
--| comprise an element of a list. For example if package L was a list
--| of lists then Dispose for L would be the Destroy of list type package L was
--| instantiated with.
--| REQUIRES
--| This procedure requires no sharing between elements of lists.
--| For example if L_int is a list of integers and L_of_L_int is a list
--| of lists of integers and two elements of L_of_L_int have the same value
--| then doing a DestroyDeep will cause an access violation to be raised.
--| The best way to avoid this is not to have sharing between list elements
--| or use copy functions when adding to the list of lists.
------------------------------------------------------------------------------
function FirstValue( --| returns the contents of the first record of the
--| list
L: in List --| the list whose first element is being
--| returned
) return ItemType;
--| Raises
--| EmptyList
--|
--| Effects
--| This returns the Item in the first position in the list. If the list
--| is empty EmptyList is raised.
-------------------------------------------------------------------------------
procedure Forward ( --| Advances the iterator.
I :in out ListIter --| The iterator.
);
--| OVERVIEW
--| This procedure can be used in conjunction with Cell to iterate over a list.
--| This is in addition to Next. Instead of writing
--|
--| I :ListIter;
--| L :List;
--| V :List_Element_Type;
--|
--| I := MakeListIter(L);
--| while More(I) loop
--| Next (I, V);
--| Print (V);
--| end loop;
--|
--| One can write
--| I := MakeListIter(L);
--| while More (I) loop
--| Print (Cell (I));
--| Forward (I);
--| end loop;
-------------------------------------------------------------------------------
function IsEmpty( --| Checks if a list is empty.
L: in List --| List being checked.
) return boolean;
--------------------------------------------------------------------------
function IsInList( --| Checks if element is an element of
--| list.
L: in List; --| list being scanned for element
Element: in ItemType --| element being searched for
) return boolean;
--| Effects
--| Walks down the list L looking for an element whose value is Element.
------------------------------------------------------------------------------
function LastValue( --| Returns the contents of the last record of
--| the list.
L: in List --| The list whose first element is being
--| returned.
) return ItemType;
--| Raises
--| EmptyList
--|
--| Effects
--| Returns the last element in a list. If the list is empty EmptyList is
--| raised.
------------------------------------------------------------------------------
function Length( --| count the number of elements on a list
L: in List --| list whose length is being computed
) return integer;
------------------------------------------------------------------------------
function MakeList ( --| This takes in an element and returns a List.
E :in ItemType
) return List;
------------------------------------------------------------------------------
function MakeListIter( --| Sets a variable to point to the head
--| of the list. This will be used to
--| prepare for iteration over a list.
L: in List --| The list being iterated over.
) return ListIter;
--| This prepares a user for iteration operation over a list. The iterater is
--| an operation which returns successive elements of the list on successive
--| calls to the iterator. There needs to be a mechanism which marks the
--| position in the list, so on successive calls to the Next operation the
--| next item in the list can be returned. This is the function of the
--| MakeListIter and the type ListIter. MakeIter just sets the Iter to the
--| the beginning of the list. On subsequent calls to Next the Iter
--| is updated with each call.
-----------------------------------------------------------------------------
function More( --| Returns true if there are more elements in
--| the and false if there aren't any more
--| the in the list.
L: in ListIter --| List being checked for elements.
) return boolean;
------------------------------------------------------------------------------
procedure Next( --| This is the iterator operation. Given
--| a ListIter in the list it returns the
--| current item and updates the ListIter.
--| If ListIter is at the end of the list,
--| More returns false otherwise it
--| returns true.
Place: in out ListIter; --| The Iter which marks the position in
--| the list.
Info: out ItemType --| The element being returned.
);
--| The iterators subprograms MakeListIter, More, and Next should be used
--| in the following way:
--|
--| L: List;
--| Place: ListIter;
--| Info: SomeType;
--|
--|
--| Place := MakeListIter(L);
--|
--| while ( More(Place) ) loop
--| Next(Place, Info);
--| process each element of list L;
--| end loop;
----------------------------------------------------------------------------
procedure ReplaceHead( --| Replace the Item at the head of the list
--| with the parameter Item.
L: in out List; --| The list being modified.
Info: in ItemType --| The information being entered.
);
--| Raises
--| EmptyList
--| Effects
--| Replaces the information in the first element in the list. Raises
--| EmptyList if the list is empty.
------------------------------------------------------------------------------
procedure ReplaceTail( --| Replace the Tail of a list
--| with a new list.
L: in out List; --| List whose Tail is replaced.
NewTail: in List --| The list which will become the
--| tail of Oldlist.
);
--| Raises
--| EmptyList
--|
--| Effects
--| Replaces the tail of a list with a new list. If the list whose tail
--| is being replaced is null EmptyList is raised.
-------------------------------------------------------------------------------
function Tail( --| returns the tail of a list L
L: in List --| the list whose tail is being returned
) return List;
--| Raises
--| EmptyList
--|
--| Effects
--| Returns a list which is the tail of the list L. Raises EmptyList if
--| L is empty. If L only has one element then Tail returns the Empty
--| list.
------------------------------------------------------------------------------
function CellValue ( --| Return the value of the element where the iterator is
--| positioned.
I :in ListIter
) return ItemType;
--| OVERVIEW
--| This returns the value of the element at the position of the iterator.
--| This is used in conjunction with Forward.
--------------------------------------------------------------------------
function Equal( --| compares list1 and list2 for equality
List1: in List; --| first list
List2: in List --| second list
) return boolean;
--| Effects
--| Returns true if for all elements of List1 the corresponding element
--| of List2 has the same value. This function uses the Equal operation
--| provided by the user. If one is not provided then = is used.
------------------------------------------------------------------------------
private
type Cell;
type List is access Cell; --| pointer added by this package
--| in order to make a list
type Cell is --| Cell for the lists being created
record
Info: ItemType;
Next: List;
end record;
type ListIter is new List; --| This prevents Lists being assigned to
--| iterators and vice versa
end Lists;
--::::::::::
--lists.bdy
--::::::::::
with unchecked_deallocation;
package body Lists is
procedure Free is new unchecked_deallocation (Cell, List);
--------------------------------------------------------------------------
function Last (L: in List) return List is
Place_In_L: List;
Temp_Place_In_L: List;
--| Link down the list L and return the pointer to the last element
--| of L. If L is null raise the EmptyList exception.
begin
if L = null then
raise EmptyList;
else
--| Link down L saving the pointer to the previous element in
--| Temp_Place_In_L. After the last iteration Temp_Place_In_L
--| points to the last element in the list.
Place_In_L := L;
while Place_In_L /= null loop
Temp_Place_In_L := Place_In_L;
Place_In_L := Place_In_L.Next;
end loop;
return Temp_Place_In_L;
end if;
end Last;
--------------------------------------------------------------------------
procedure Attach (List1: in out List;
List2: in List ) is
EndOfList1: List;
--| Attach List2 to List1.
--| If List1 is null return List2
--| If List1 equals List2 then raise CircularList
--| Otherwise get the pointer to the last element of List1 and change
--| its Next field to be List2.
begin
if List1 = null then
List1 := List2;
return;
elsif List1 = List2 then
raise CircularList;
else
EndOfList1 := Last (List1);
EndOfList1.Next := List2;
end if;
end Attach;
--------------------------------------------------------------------------
procedure Attach (L: in out List;
Element: in ItemType ) is
NewEnd: List;
--| Create a list containing Element and attach it to the end of L
begin
NewEnd := new Cell'(Info => Element, Next => null);
Attach (L, NewEnd);
end;
--------------------------------------------------------------------------
function Attach (Element1: in ItemType;
Element2: in ItemType ) return List is
NewList: List;
--| Create a new list containing the information in Element1 and
--| attach Element2 to that list.
begin
NewList := new Cell'(Info => Element1, Next => null);
Attach (NewList, Element2);
return NewList;
end;
--------------------------------------------------------------------------
procedure Attach (Element: in ItemType;
L: in out List ) is
--| Create a new cell whose information is Element and whose Next
--| field is the list L. This prepends Element to the List L.
begin
L := new Cell'(Info => Element, Next => L);
end;
--------------------------------------------------------------------------
function Attach ( List1: in List;
List2: in List ) return List is
Last_Of_List1: List;
begin
if List1 = null then
return List2;
elsif List1 = List2 then
raise CircularList;
else
Last_Of_List1 := Last (List1);
Last_Of_List1.Next := List2;
return List1;
end if;
end Attach;
-------------------------------------------------------------------------
function Attach( L: in List;
Element: in ItemType ) return List is
NewEnd: List;
Last_Of_L: List;
--| Create a list called NewEnd and attach it to the end of L.
--| If L is null return NewEnd
--| Otherwise get the last element in L and make its Next field
--| NewEnd.
begin
NewEnd := new Cell'(Info => Element, Next => null);
if L = null then
return NewEnd;
else
Last_Of_L := Last (L);
Last_Of_L.Next := NewEnd;
return L;
end if;
end Attach;
--------------------------------------------------------------------------
function Attach (Element: in ItemType;
L: in List ) return List is
begin
return (new Cell'(Info => Element, Next => L));
end Attach;
---------------------------------------------------------------------------
function Copy (L: in List) return List is
--| If L is null return null
--| Otherwise recursively copy the list by first copying the information
--| at the head of the list and then making the Next field point to
--| a copy of the tail of the list.
begin
if L = null then
return null;
else
return new Cell'(Info => L.Info, Next => Copy (L.Next));
end if;
end Copy;
--------------------------------------------------------------------------
function CopyDeep (L: in List) return List is
--| If L is null then return null.
--| Otherwise copy the first element of the list into the head of the
--| new list and copy the tail of the list recursively using CopyDeep.
begin
if L = null then
return null;
else
return new Cell'( Info => Copy (L.Info), Next => CopyDeep(L.Next));
end if;
end CopyDeep;
--------------------------------------------------------------------------
function Create return List is
--| Return the empty list.
begin
return null;
end Create;
--------------------------------------------------------------------------
procedure DeleteHead (L: in out List) is
TempList: List;
--| Remove the element of the head of the list and return it to the heap.
--| If L is null EmptyList.
--| Otherwise save the Next field of the first element, remove the first
--| element and then assign to L the Next field of the first element.
begin
if L = null then
raise EmptyList;
else
TempList := L.Next;
Free (L);
L := TempList;
end if;
end DeleteHead;
--------------------------------------------------------------------------
function DeleteItem( --| remove the first occurrence of Element
--| from L
L: in List; --| list element is being removed from
Element: in ItemType --| element being removed
) return List is
I :List;
Result :List;
Found :boolean := false;
begin
--| ALGORITHM
--| Attach all elements of L to Result except the first element in L
--| whose value is Element. If the current element pointed to by I
--| is not equal to element or the element being skipped was found
--| then attach the current element to Result.
I := L;
while (I /= null) loop
if (not Equal (I.Info, Element)) or (Found) then
Attach (Result, I.Info);
else
Found := true;
end if;
I := I.Next;
end loop;
return Result;
end DeleteItem;
------------------------------------------------------------------------------
function DeleteItems ( --| remove all occurrences of Element
--| from L.
L: in List; --| The List element is being removed from
Element: in ItemType --| element being removed
) return List is
I :List;
Result :List;
begin
--| ALGORITHM
--| Walk over the list L and if the current element does not equal
--| Element then attach it to the list to be returned.
I := L;
while I /= null loop
if not Equal (I.Info, Element) then
Attach (Result, I.Info);
end if;
I := I.Next;
end loop;
return Result;
end DeleteItems;
-------------------------------------------------------------------------------
procedure DeleteItem (L: in out List;
Element: in ItemType ) is
Temp_L :List;
--| Remove the first element in the list with the value Element.
--| If the first element of the list is equal to element then
--| remove it. Otherwise, recurse on the tail of the list.
begin
if Equal(L.Info, Element) then
DeleteHead(L);
else
DeleteItem(L.Next, Element);
end if;
end DeleteItem;
--------------------------------------------------------------------------
procedure DeleteItems (L: in out List;
Element: in ItemType ) is
Place_In_L :List; --| Current place in L.
Last_Place_In_L :List; --| Last place in L.
Temp_Place_In_L :List; --| Holds a place in L to be removed.
--| Walk over the list removing all elements with the value Element.
begin
Place_In_L := L;
Last_Place_In_L := null;
while (Place_In_L /= null) loop
--| Found an element equal to Element
if Equal(Place_In_L.Info, Element) then
--| If Last_Place_In_L is null then we are at first element
--| in L.
if Last_Place_In_L = null then
Temp_Place_In_L := Place_In_L;
L := Place_In_L.Next;
else
Temp_Place_In_L := Place_In_L;
--| Relink the list Last's Next gets Place's Next
Last_Place_In_L.Next := Place_In_L.Next;
end if;
--| Move Place_In_L to the next position in the list.
--| Free the element.
--| Do not update the last element in the list it remains the
--| same.
Place_In_L := Place_In_L.Next;
Free (Temp_Place_In_L);
else
--| Update the last place in L and the place in L.
Last_Place_In_L := Place_In_L;
Place_In_L := Place_In_L.Next;
end if;
end loop;
--| If we have not found an element raise an exception.
end DeleteItems;
------------------------------------------------------------------------------
procedure Destroy (L: in out List) is
Place_In_L: List;
HoldPlace: List;
--| Walk down the list removing all the elements and set the list to
--| the empty list.
begin
Place_In_L := L;
while Place_In_L /= null loop
HoldPlace := Place_In_L;
Place_In_L := Place_In_L.Next;
Free (HoldPlace);
end loop;
L := null;
end Destroy;
--------------------------------------------------------------------------
procedure DestroyDeep (L: in out List) is
Place_In_L: List;
HoldPlace: List;
--| Walk down the list removing all the elements and set the list to
--| the empty list.
begin
Place_In_L := L;
while Place_In_L /= null loop
HoldPlace := Place_In_L;
Place_In_L := Place_In_L.Next;
Dispose (HoldPlace.Info);
Free (HoldPlace);
end loop;
L := null;
end DestroyDeep;
--------------------------------------------------------------------------
function FirstValue (L: in List) return ItemType is
--| Return the first value in the list.
begin
if L = null then
raise EmptyList;
else
return (L.Info);
end if;
end FirstValue;
--------------------------------------------------------------------------
procedure Forward (I: in out ListIter) is
--| Return the pointer to the next member of the list.
begin
if I = null then
raise NoMore;
else
I := ListIter (I.Next);
end if;
end Forward;
--------------------------------------------------------------------------
function IsInList (L: in List;
Element: in ItemType ) return boolean is
Place_In_L: List;
--| Check if Element is in L. If it is return true otherwise return false.
begin
Place_In_L := L;
while Place_In_L /= null loop
if Equal(Place_In_L.Info, Element) then
return true;
end if;
Place_In_L := Place_In_L.Next;
end loop;
return false;
end IsInList;
--------------------------------------------------------------------------
function IsEmpty (L: in List) return boolean is
--| Is the list L empty.
begin
return (L = null);
end IsEmpty;
--------------------------------------------------------------------------
function LastValue (L: in List) return ItemType is
LastElement: List;
--| Return the value of the last element of the list. Get the pointer
--| to the last element of L and then return its information.
begin
LastElement := Last (L);
return LastElement.Info;
end LastValue;
--------------------------------------------------------------------------
function Length (L: in List) return integer is
--| Recursively compute the length of L. The length of a list is
--| 0 if it is null or 1 + the length of the tail.
begin
if L = null then
return (0);
else
return (1 + Length (Tail (L)));
end if;
end Length;
--------------------------------------------------------------------------
function MakeList (
E :in ItemType
) return List is
begin
return new Cell ' (Info => E, Next => null);
end;
--------------------------------------------------------------------------
function MakeListIter (L: in List) return ListIter is
--| Start an iteration operation on the list L. Do a type conversion
--| from List to ListIter.
begin
return ListIter (L);
end MakeListIter;
--------------------------------------------------------------------------
function More (L: in ListIter) return boolean is
--| This is a test to see whether an iteration is complete.
begin
return L /= null;
end;
--------------------------------------------------------------------------
procedure Next (Place: in out ListIter;
Info: out ItemType ) is
PlaceInList: List;
--| This procedure gets the information at the current place in the List
--| and moves the ListIter to the next postion in the list.
--| If we are at the end of a list then exception NoMore is raised.
begin
if Place = null then
raise NoMore;
else
PlaceInList := List(Place);
Info := PlaceInList.Info;
Place := ListIter(PlaceInList.Next);
end if;
end Next;
--------------------------------------------------------------------------
procedure ReplaceHead (L: in out List;
Info: in ItemType ) is
--| This procedure replaces the information at the head of a list
--| with the given information. If the list is empty the exception
--| EmptyList is raised.
begin
if L = null then
raise EmptyList;
else
L.Info := Info;
end if;
end ReplaceHead;
--------------------------------------------------------------------------
procedure ReplaceTail (L: in out List;
NewTail: in List ) is
Temp_L: List;
--| This destroys the tail of a list and replaces the tail with
--| NewTail. If L is empty EmptyList is raised.
begin
Destroy(L.Next);
L.Next := NewTail;
exception
when constraint_error =>
raise EmptyList;
end ReplaceTail;
--------------------------------------------------------------------------
function Tail (L: in List) return List is
--| This returns the list which is the tail of L. If L is null
--| EmptyList is raised.
begin
if L = null then
raise EmptyList;
else
return L.Next;
end if;
end Tail;
--------------------------------------------------------------------------
function CellValue (
I :in ListIter
) return ItemType is
L :List;
begin
-- Convert I to a List type and then return the value it points to.
L := List(I);
return L.Info;
end CellValue;
--------------------------------------------------------------------------
function Equal (List1: in List;
List2: in List ) return boolean is
PlaceInList1: List;
PlaceInList2: LIst;
Contents1: ItemType;
Contents2: ItemType;
--| This function tests to see if two lists are equal. Two lists
--| are equal if for all the elements of List1 the corresponding
--| element of List2 has the same value. Thus if the 1st elements
--| are equal and the second elements are equal and so up to n.
--| Thus a necessary condition for two lists to be equal is that
--| they have the same number of elements.
--| This function walks over the two list and checks that the
--| corresponding elements are equal. As soon as we reach
--| the end of a list (PlaceInList = null) we fall out of the loop.
--| If both PlaceInList1 and PlaceInList2 are null after exiting the loop
--| then the lists are equal. If they both are not null the lists aren't
--| equal. Note that equality on elements is based on a user supplied
--| function Equal which is used to test for item equality.
begin
PlaceInList1 := List1;
PlaceInList2 := List2;
while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop
if not Equal (PlaceInList1.Info, PlaceInList2.Info) then
return false;
end if;
PlaceInList1 := PlaceInList1.Next;
PlaceInList2 := PlaceInList2.Next;
end loop;
return ((PlaceInList1 = null) and (PlaceInList2 = null) );
end Equal;
end Lists;
--------------------------------------------------------------------------
--::::::::::
--pgfile.spc
--::::::::::
with Text_IO;
with String_Pkg;
package Paginated_Output is
--| Create paginated text files with user defined heading, footing, and page length.
pragma Page;
--| Overview:
--| The Paginated_Output package is used to create paginated output files.
--| When such a file is created, the page length, page header and footer length
--| are specified. Several operations are provided for setting/replacing the
--| header or the footer text which will appear on each output page. An escape
--| sequence ~X(Ann) may be used to insert texts in the header/footer texts.
--| The escape character X may be:
--|-
--| F the current external file name
--| P the current page number
--| D the current date (eg. 03/15/85)
--| C the current calendar date (eg. March 15, 1985)
--| T the current time (eg. 04:53:32)
--|+
--| The optional alignment character A may be:
--|-
--| L left align the text
--| R right allign the text
--| C center the text
--|+
--| nn following the alignment character specifies the number of spaces the
--| text will displace in the header/footer texts.
--|
--| Case is not significant after the tilde (~). If the tilde is followed by
--| any other character, only the second character is printed unless the line
--| ends with a tilde in which case the line will be terminated one character
--| before the tilde.
--|
--| The header is printed just before the first line of a page is output, and
--| the footer is printed just after the last line. Thus, if a paginated file
--| is opened and closed without any calls to print a line in between, the
--| output is a null file.
--|
--| This package knows nothing about (and places no limits on) the length or
--| contents of each line sent to the output file. In particular, if the line
--| contains ASCII control codes for new line, form feed, and/or vertical tab
--| the output file will not be properly paginated. Normal usage is to call
--| Create_Paginated_File, call Set_Header/Set_Footer, call Put_Line repeatedly
--| to output a sequence of lines of text, and finally call
--| Close_Paginated_File to complete the last page and close the file.
--| N/A: Effects, Requires, Modifies, Raises
pragma Page;
-- Exceptions --
Files_Already_Linked --| Raised if an attempt is made to
: exception; --| link two linked paginated files
File_Already_Open : exception; --| Raised if create is attempted
--| for an already existing file.
File_Error : exception; --| Raised if unable to open a file
--| other than File_Already_Open
File_Not_Open : exception; --| Raised if close is attempted
--| for an unopened file.
Invalid_Count : exception; --| Raised if a requested count
--| can not be serviced.
Invalid_File : exception; --| Raised if output is attempted
--| with an invalid file handle.
Output_Error : exception; --| Raised if error is encountered
--| during an output operation.
Page_Layout_Error : exception; --| Raised if page specification
--| is invalid.
Page_Overflow : exception; --| Raised if specified reserve
--| value exceeds the page size.
Text_Overflow : exception; --| Raised if header/footer text
--| overflows area.
pragma Page;
-- Packages --
package TIO renames Text_IO;
package SP renames String_Pkg;
-- Types --
subtype Date_String is STRING (1 .. 8);
--| Date string
subtype Time_String is STRING (1 .. 8);
--| Time string
type Variable_String_Array is --| Array of variable length strings
array (POSITIVE range <>) of SP.String_Type;
type Paginated_File_Handle is --| Handle to be passed around in a
limited private; --| program that uses paginated output.
type Paginated_Output_Mode is (STD, CUR);
--| Paginated output mode
pragma Page;
-- Operations --
procedure Create_Paginated_File(--| Create a paginated output file
--| and return the file handle.
File_Name : in STRING := "";
--| The name of the file to be created.
File_Handle : in out Paginated_File_Handle;
--| Handle to be used for subsequent
--| operations
Page_Size : in NATURAL := 66;
--| The number of lines per page
Header_Size : in NATURAL := 6;
--| The number of header text lines
Footer_Size : in NATURAL := 6;
--| The number of footer text lines
Output_Mode : in Paginated_Output_Mode := STD
--| Output mode
);
--| Raises:
--| File_Already_Open, File_Error, Page_Layout_Error
--| Requires:
--| File_Name is an valid external name of the file to be created (If
--| it is omitted, the current output file is selected). Page_Size,
--| Header_Size, and Footer_Size are optional values (if omitted 66,
--| 6, and 6 are set, respectively) to be used for the page layout
--| of the file to be created. Page_Size specifies the total number
--| of lines per page (including the areas for header and footer).
--| Header_Size and Footer_Size specify the number of lines to be
--| reserved for the header and footer areas, respectively.
--| Effects:
--| Creates a new paginated file with Page_Size number of lines
--| per page and Header_Size and Footer_Size number of lines
--| reserved for header and footer, respectively. Access to the
--| paginated file control structure Paginated_File_Handle is
--| returned for use in subsequent operations.
--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised. Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the same
--| exception is raised. This guarantees that at least one line of
--| text can appear on each output page.
--| If the output file with the specified File_Name is already open
--| File_Already_Open exception is raised.
--| If the file cannot be opened for any other reason, the exception
--| File_Error is raise.
--| N/A: Modifies
pragma Page;
procedure Set_Standard_Paginated_File(
--| Set the standard paginated output file
--| characteristics.
File_Name : in STRING; --| The name of the file to be set.
Page_Size : in NATURAL; --| The number of lines per page
Header_Size : in NATURAL; --| The number of header text lines
Footer_Size : in NATURAL --| The number of footer text lines
);
--| Raises:
--| File_Already_Open, File_Error, Page_Layout_Error
--| Requires:
--| File_Name is an valid external name of the file to be created
--| Page_Size, Header_Size, and Footer_Size are used for the page layout
--| of the file.
--| Effects:
--| Sets the standard paginated file to the given file name and sets the
--| page layout as specified.
--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised. Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the same
--| exception is raised. This guarantees that at least one line of
--| text can appear on each output page.
--| If the output file with the specified File_Name is already open
--| File_Already_Open exception is raised.
--| If the file cannot be opened for any other reason, the exception
--| File_Error is raise.
--| N/A: Modifies
pragma page;
procedure Duplicate_Paginated_File(
--| Duplicate an already existing
--| paginated file and return the
--| file handle.
Old_Handle : in Paginated_File_Handle;
--| Existing paginated file handle
New_Handle : in out Paginated_File_Handle
--| Handle of the new paginated file
);
--| Requires:
--| Old_Handle for the existing paginated file to be duplicated.
--| The new handle (duplocated from Old_Handle) to be used to refer
--| to the same paginated file.
--| Effects:
--| Handle for the aginated file refered to be Old_Handle will be
--| duplicated in New_Handle.
--| N/A: Raises, Modifies, Errors
pragma Page;
procedure Set_Page_Layout( --| Set the page layout for the
--| paginated file.
Page_Size : in NATURAL; --| The number of lines per page
Header_Size : in NATURAL; --| The number of header text lines
Footer_Size : in NATURAL --| The number of footer text lines
);
--| Raises:
--| Page_Layout_Error
--| Requires:
--| Page_Size specifies the total number of lines per page (including the
--| area for header & footer).
--| Header_Size and Footer_Size specifies the number of lines to be
--| reserved for the header and footer area, respectively.
--| Effects:
--| A paginated file is set with Page_Size number of lines per
--| page and Header_Size and Footer_Size number of lines
--| reserved for header and footer, respectively.
--| A page eject is performed if not at the top of the page before
--| the new page layout values are set.
--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised. Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the exception
--| Page_Layout_Error is raised.
--| N/A: Modifies
procedure Set_Page_Layout( --| Set the page layout for the
--| paginated file.
File_Handle : in Paginated_File_Handle;
--| The paginated file to be set
--| with the given page layout
Page_Size : in NATURAL; --| The number of lines per page
Header_Size : in NATURAL; --| The number of header text lines
Footer_Size : in NATURAL --| The number of footer text lines
);
--| Raises:
--| Page_Layout_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Page_Size specifies the total
--| number of lines per page (including the area for header & footer).
--| Header_Size and Footer_Size specifies the number of lines to be
--| reserved for the header and footer area, respectively.
--| Effects:
--| A paginated file is set with Page_Size number of lines per
--| page and Header_Size and Footer_Size number of lines
--| reserved for header and footer, respectively.
--| A page eject is performed if not at the top of the page before
--| the new page layout values are set.
--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised. Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the exception
--| Page_Layout_Error is raised.
--| N/A: Modifies
pragma Page;
procedure Link_Paginated_File( --| Link paginated files into a chain
File_Handle1 : in Paginated_File_Handle;
--| Handle to be linked
File_Handle2 : in Paginated_File_Handle
--| Handle to be linked
);
--| Raises:
--| Files_Already_Linked
--| Requires:
--| File_Handle1 and File_Handle2, access to the paginated file control
--| structures.
--| Effects:
--| File_Handle1 and File_Handle2 in a chain so in the given order such that
--| subsequent operations to File_Handle1 are reflected in both files.
--| Any operations to File_Handle2 are NOT performed for File_Handle1.
--| Errors:
--| If either of the files have been linked, raises Files_Already_Linked.
--| N/A: Modifies
procedure Unlink_Paginated_File(
File_Handle : in Paginated_File_Handle
);
--| Requires:
--| File_Handle which accesses a paginated file control structure.
--| Effects:
--| Takes File_Handle out of a previously linked chain.
--| N/A: Raises, Modifies, Errors
pragma Page;
procedure Set_File_Name( --| Set arbitrary file name for ~f substitute
File_Handle : in Paginated_File_Handle;
--| The paginated file handle
File_Name : in STRING --| The name of the file to be set.
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is a file handle to a paginated file
--| File_Name is any name of the file to be saved for ~f substitution
--| Effects:
--| Sets the name of the ~f substitution file to File_Name
--| Errors:
--| If the file handel is invalid Invalid_File is raise.
--| N/A: Modifies
procedure Reset_File_Name( --| Reset file name to default
File_Handle : in Paginated_File_Handle
);
procedure Set_File_Name( --| Set arbitrary file name for ~f substitute
File_Name : in STRING --| The name of the file to be set.
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Name is any name of the file to be saved for ~f substitution
--| for paginated standard output
--| Effects:
--| Sets the name of the ~f substitution file to File_Name
--| N/A: Modifies
procedure Reset_File_Name; --| Reset file name to default
pragma Page;
procedure Set_Date( --| Set arbitrary string for ~d date substitute
File_Handle : in Paginated_File_Handle;
--| The paginated file handle
Date : in Date_String--| The date string
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is a file handle to a paginated file
--| Date is any string to be saved for ~d substitution
--| Effects:
--| Sets the string of the ~d substitution to date
--| Errors:
--| If the file handel is invalid Invalid_File is raise.
--| N/A: Modifies
procedure Reset_Date( --| Reset date to current date
File_Handle : in Paginated_File_Handle
);
procedure Set_Date( --| Set arbitrary string for ~d date substitute
Date : in Date_String --| The date string
);
--| Requires:
--| Date is any string to be saved for ~d substitution
--| Effects:
--| Sets the string of the ~d substitution to date
--| N/A: Raises, Errors, Modifies
procedure Reset_Date; --| Reset date to current date
pragma Page;
procedure Set_Calendar( --| Set arbitrary string for ~c date substitute
File_Handle : in Paginated_File_Handle;
--| The paginated file handle
Calendar : in STRING --| The date string
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is a file handle to a paginated file
--| Date is any string to be saved for ~c substitution
--| Effects:
--| Sets the string of the ~c substitution to date
--| Errors:
--| If the file handel is invalid Invalid_File is raise.
--| N/A: Modifies
procedure Reset_Calendar( --| Reset date to current calendar date
File_Handle : in Paginated_File_Handle
);
procedure Set_Calendar( --| Set arbitrary string for ~c date substitute
Calendar : in STRING --| The date string
);
--| Requires:
--| Date is any string to be saved for ~c substitution
--| Effects:
--| Sets the string of the ~c substitution to date
--| N/A: Raises, Errors, Modifies
procedure Reset_Calendar; --| Reset date to current calendar date
pragma Page;
procedure Set_Time( --| Set arbitrary string for ~t time substitute
File_Handle : in Paginated_File_Handle;
--| The paginated file handle
Time : in Time_String--| The time string
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is a file handle to a paginated file
--| Time is any string to be saved for ~t substitution
--| Effects:
--| Sets the string of the ~t substitution to time
--| Errors:
--| If the file handel is invalid Invalid_File is raise.
--| N/A: Modifies
procedure Reset_Time( --| Reset time to current time
File_Handle : in Paginated_File_Handle
);
procedure Set_Time( --| Set arbitrary string for ~t time substitute
Time : in Time_String --| The time string
);
--| Requires:
--| Time is any string to be saved for ~t substitution
--| Effects:
--| Sets the string of the ~t substitution to time
--| N/A: Raises, Errors, Modifies
procedure Reset_Time; --| Reset time to current time
pragma Page;
procedure Set_Page( --| Set arbitrary string for ~p page substitute
File_Handle : in Paginated_File_Handle;
--| The paginated file handle
Page : in POSITIVE --| The page number
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is a file handle to a paginated file
--| page is any string to be saved for ~p substitution
--| Effects:
--| Sets the page number for ~p substitution
--| Errors:
--| If the file handel is invalid Invalid_File is raise.
--| N/A: Modifies
procedure Reset_Page( --| Reset page to 1
File_Handle : in Paginated_File_Handle
);
procedure Set_Page( --| Set arbitrary string for ~p page substitute
Page : in POSITIVE --| The page number
);
--| Requires:
--| page is any string to be saved for ~p substitution
--| Effects:
--| Sets the page number for ~p substitution
--| N/A: Raises, Errors, Modifies
procedure Reset_Page; --| Rest page to 1
pragma Page;
procedure Set_Header(
Header_Text : in Variable_String_Array
);
procedure Set_Header( --| Set the header text on a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Text : in Variable_String_Array
--| Sequence of header lines
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the array
--| of text to be used for the page header.
--| Effects:
--| The header text of File_Handle is set to Header_Text. Note that
--| the replaced header text will not be printed until the next
--| page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a header text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Header(
Header_Line : in POSITIVE;
Header_Text : in STRING
);
procedure Set_Header( --| Replace a line of header text on a
--| paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Line : in POSITIVE; --| Line number of header to be replaced
Header_Text : in STRING --| Header line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the text
--| to replace the existing header line at Header_Line.
--| Effects:
--| The header text of File_Handle at Header_Line is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Header(
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
);
procedure Set_Header( --| Replace a line of header text on a
--| paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Line : in POSITIVE; --| Line number of header to be replaced
Header_Text : in SP.String_Type
--| Header line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the text
--| to replace the existing header line at Header_Line.
--| Effects:
--| The header text of File_Handle at Header_Line is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
pragma Page;
procedure Set_Odd_Header(
Header_Text : in Variable_String_Array
);
procedure Set_Odd_Header( --| Set the header text for the odd
--| pages of a paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Text : in Variable_String_Array
--| Sequence of header lines
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the array
--| of text to be used for the odd page header.
--| Effects:
--| The header text for odd pages of File_Handle is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a header text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Odd_Header(
Header_Line : in POSITIVE;
Header_Text : in STRING
);
procedure Set_Odd_Header( --| Replace a line of header text on
--| the odd pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Line : in POSITIVE; --| Line number of header to be replaced
Header_Text : in STRING --| Header line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the text
--| to replace the existing odd page header line at Header_Line.
--| Effects:
--| The odd page header text of File_Handle at Header_Line is set
--| to Header_Text. Note that the replaced header text will not be
--| printed until the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Odd_Header(
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
);
procedure Set_Odd_Header( --| Replace a line of header text on
--| the odd pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Line : in POSITIVE; --| Line number of header to be replaced
Header_Text : in SP.String_Type
--| Header line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the text
--| to replace the existing odd page header line at Header_Line.
--| Effects:
--| The odd page header text of File_Handle at Header_Line is set
--| to Header_Text. Note that the replaced header text will not be
--| printed until the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
pragma Page;
procedure Set_Even_Header(
Header_Text : in Variable_String_Array
);
procedure Set_Even_Header( --| Set the header text for the even
--| pages of a paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Text : in Variable_String_Array
--| Sequence of header lines
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the array
--| of text to be used for the even page header.
--| Effects:
--| The header text for even pages of File_Handle is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a header text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Even_Header(
Header_Line : in POSITIVE;
Header_Text : in STRING
);
procedure Set_Even_Header( --| Replace a line of header text on
--| the even pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Line : in POSITIVE; --| Line number of header to be replaced
Header_Text : in STRING --| Header line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the text
--| to replace the existing even page header line at Header_Line.
--| Effects:
--| The even page header text of File_Handle at Header_Line is set
--| to Header_Text. Note that the replaced header text will not be
--| printed until the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Even_Header(
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
);
procedure Set_Even_Header( --| Replace a line of header text on
--| the even pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the header text
Header_Line : in POSITIVE; --| Line number of header to be replaced
Header_Text : in SP.String_Type
--| Header line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Header_Text is the text
--| to replace the existing even page header line at Header_Line.
--| Effects:
--| The even page header text of File_Handle at Header_Line is set
--| to Header_Text. Note that the replaced header text will not be
--| printed until the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
pragma Page;
procedure Set_Footer(
Footer_Text : in Variable_String_Array
);
procedure Set_Footer( --| Set the footer text on a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Text : in Variable_String_Array
--| Sequence of lines for the footer
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the array
--| of text to be used for the page footer.
--| Effects:
--| The footer text of File_Handle is set to Footer_Text. Note that
--| the replaced footer text will not be printed until the next
--| page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a footer text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in STRING
);
procedure Set_Footer( --| Replace a line of header text on a
--| paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Line : in POSITIVE; --| Line number of footer to be replaced
Footer_Text : in STRING --| Footer line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the text
--| to replace the existing footer line at Footer_Line.
--| Effects:
--| The footer text of File_Handle at Footer_Line is set to Header_Text.
--| Note that the replaced footer text will not be printed until
--| the next page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
);
procedure Set_Footer( --| Replace a line of footer text on a
--| paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Line : in POSITIVE; --| Line number of footer to be replaced
Footer_Text : in SP.String_Type
--| Footer line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the text
--| to replace the existing footer line at Footer_Line.
--| Effects:
--| The footer text of File_Handle at Footer_Line is set to Header_Text.
--| Note that the replaced footer text will not be printed until
--| the next page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
pragma Page;
procedure Set_Odd_Footer(
Footer_Text : in Variable_String_Array
);
procedure Set_Odd_Footer( --| Set the footer text for the odd
--| pages of a paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Text : in Variable_String_Array
--| Sequence of lines for the footer
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the array
--| of text to be used for the odd page footer.
--| Effects:
--| The footer text for odd pages of File_Handle is set to Footer_Text.
--| Note that the replaced footer text will not be printed until
--| the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a footer text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Odd_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in STRING
);
procedure Set_Odd_Footer( --| Replace a line of footer text on
--| the odd pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Line : in POSITIVE; --| Line number of footer to be replaced
Footer_Text : in STRING --| Footer line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the text
--| to replace the existing odd page footer line at Footer_Line.
--| Effects:
--| The odd page footer text of File_Handle at Footer_Line is set
--| to Footer_Text. Note that the replaced footer text will not be
--| printed until the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Odd_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
);
procedure Set_Odd_Footer( --| Replace a line of footer text on
--| the odd pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Line : in POSITIVE; --| Line number of footer to be replaced
Footer_Text : in SP.String_Type
--| Footer line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the text
--| to replace the existing odd page footer line at Footer_Line.
--| Effects:
--| The odd page footer text of File_Handle at Footer_Line is set
--| to Footer_Text. Note that the replaced footer text will not be
--| printed until the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
pragma Page;
procedure Set_Even_Footer(
Footer_Text : in Variable_String_Array
);
procedure Set_Even_Footer( --| Set the footer text for the even
--| pages of a paginated output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Text : in Variable_String_Array
--| Sequence of lines for the footer
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the array
--| of text to be used for the even page footer.
--| Effects:
--| The footer text for even pages of File_Handle is set to Footer_Text.
--| Note that the replaced footer text will not be printed until
--| the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a footer text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Even_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in STRING
);
procedure Set_Even_Footer( --| Replace a line of footer text on
--| the even pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Line : in POSITIVE; --| Line number of footer to be replaced
Footer_Text : in STRING --| Footer line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the text
--| to replace the existing even page footer line at Footer_Line.
--| Effects:
--| The even page footer text of File_Handle at Footer_Line is set
--| to Footer_Text. Note that the replaced footer text will not be
--| printed until the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
procedure Set_Even_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
);
procedure Set_Even_Footer( --| Replace a line of footer text on
--| the even pages of a paginated
--| output file.
File_Handle : in Paginated_File_Handle;
--| Paginated file to be set
--| with the footer text
Footer_Line : in POSITIVE; --| Line number of footer to be replaced
Footer_Text : in SP.String_Type
--| Footer line to replace
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Footer_Text is the text
--| to replace the existing even page footer line at Footer_Line.
--| Effects:
--| The even page footer text of File_Handle at Footer_Line is set
--| to Footer_Text. Note that the replaced footer text will not be
--| printed until the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| N/A: Modifies
pragma Page;
procedure Clear_Header;
procedure Clear_Header( --| Set the header text on a paginated
--| output file to null lines
File_Handle : in Paginated_File_Handle
--| Paginated file to be set
--| with the header text
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| The header text of File_Handle is cleared to null lines.
--| The replaced null header will not be printed until the next
--| page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Clear_Odd_Header;
procedure Clear_Odd_Header( --| Set the header text for the odd
--| pages to null lines
File_Handle : in Paginated_File_Handle
--| Paginated file to be set
--| with the header text
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| The header text for odd pages of File_Handle is cleared to null.
--| Note that the replaced null header text will not be printed until
--| the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Clear_Even_Header;
procedure Clear_Even_Header( --| Set the header text for the even
--| pages to null lines
File_Handle : in Paginated_File_Handle
--| Paginated file to be set
--| with the header text
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| The header text for even pages of File_Handle is cleared to null.
--| Note that the replaced null header text will not be printed until
--| the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Clear_Footer;
procedure Clear_Footer( --| Set the footer text on a paginated
--| output file to null lines
File_Handle : in Paginated_File_Handle
--| Paginated file to be set
--| with the footer text
);
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| The footer text of File_Handle is cleared to null lines.
--| The replaced null footer will not be printed until the next
--| page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Clear_Odd_Footer;
procedure Clear_Odd_Footer( --| Set the footer text for the odd
--| pages to null lines
File_Handle : in Paginated_File_Handle
--| Paginated file to be set
--| with the footer text
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| The footer text for odd pages of File_Handle is cleared to null.
--| Note that the replaced null footer text will not be printed until
--| the next odd page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Clear_Even_Footer;
procedure Clear_Even_Footer( --| Set the footer text for the even
--| pages to null lines
File_Handle : in Paginated_File_Handle
--| Paginated file to be set
--| with the footer text
);
--| Raises:
--| Invalid_File, Text_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| The footer text for even pages of File_Handle is cleared to null.
--| Note that the replaced null footer text will not be printed until
--| the next even page of the output.
--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Close_Paginated_File;
procedure Close_Paginated_File( --| Complete the last page and close
--| the paginated file.
File_Handle : in out Paginated_File_Handle
--| The paginated file to be closed
);
--| Raises:
--| Invalid_File, File_Not_Open
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| Completes the last page of output and closes the output file.
--| Errors:
--| If File_Handle is not a valid Paginated_File_Handle, the exception
--| Invalid_File is raised. If an error occurs in closing the file,
--| File_Not_Open is raised.
--| N/A: Modifies
pragma Page;
procedure Put(
Text : in Variable_String_Array
);
procedure Put( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output the text
Text : in Variable_String_Array
--| The text to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text is a string of
--| characters to be written to the paginated output file.
--| Effects:
--| Outputs Text of text to File_Handle. If Text is the first string of the
--| first line to be printed on a page, the page header is printed before
--| printing the text.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
procedure Put(
Text : in SP.String_Type
);
procedure Put( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output the text
Text : in SP.String_Type
--| The text to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text is a string of
--| characters to be written to the paginated output file.
--| Effects:
--| Outputs Text of text to File_Handle. If Text is the first string of the
--| first line to be printed on a page, the page header is printed before
--| printing the text.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
procedure Put(
Text : in STRING
);
procedure Put( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output the text
Text : in STRING --| The text to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text is a string of
--| characters to be written to the paginated output file.
--| Effects:
--| Outputs Text of text to File_Handle. If Text is the first string of the
--| first line to be printed on a page, the page header is printed before
--| printing the string.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
procedure Put(
Text : in CHARACTER
);
procedure Put( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output the text
Text : in CHARACTER --| The text to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text is a the characters to be
--| written to the paginated output file.
--| Effects:
--| Outputs Text of text to File_Handle. If Text is the first character of the
--| first line to be printed on a page, the page header is printed before
--| printing the string.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
pragma Page;
procedure Space(
Count : in NATURAL
);
procedure Space( --| Output a specified number of spaces
File_Handle : in Paginated_File_Handle;
--| The paginated file to output the line
Count : in NATURAL --| Number of spaces
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Count is the number of horizontal
--| spaces to be output.
--| Effects:
--| Output Count number of blanks to File_Handle.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
pragma Page;
procedure Put_Line(
Text_Line : in Variable_String_Array
);
procedure Put_Line( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to output the line
Text_Line : in Variable_String_Array
--| The line to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text_Line is a string of
--| characters to be written to the paginated output file.
--| Effects:
--| Outputs Text_Line of text to File_Handle. If Text_Line is the
--| first line to be printed on a page, the page header is printed
--| before the line. If it is the last line on a page, the page
--| footer followed by a page terminator is written immediately
--| after the line is written.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
procedure Put_Line(
Text_Line : in SP.String_Type
);
procedure Put_Line( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output the line
Text_Line : in SP.String_Type
--| The line to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text_Line is a string of
--| characters to be written to the paginated output file.
--| Effects:
--| Outputs Text_Line of text to File_Handle. If Text_Line is the
--| first line to be printed on a page, the page header is printed
--| before the line. If it is the last line on a page, the page
--| footer followed by a page terminator is written immediately
--| after the line is written.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
procedure Put_Line(
Text_Line : in STRING
);
procedure Put_Line( --| Output a line on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output the line
Text_Line : in STRING --| The line to be output.
);
--| Raises:
--| Invalid_File, Output_Error
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Text_Line is a string of
--| characters to be written to the paginated output file.
--| Effects:
--| Outputs Text_Line of text to File_Handle. If Text_Line is the
--| first line to be printed on a page, the page header is printed
--| before the line. If it is the last line on a page, the page
--| footer followed by a page terminator is written immediately
--| after the line is written.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If an error
--| occurs during output, Output_Error is raised.
--| N/A: Modifies
pragma Page;
procedure Space_Line(
Count : in NATURAL := 1
);
procedure Space_Line( --| Output one or more spaces on a
--| paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output spaces
Count : in NATURAL := 1
--| The number of spaces.
);
--| Raises:
--| Invalid_File, Output_Error, Invalid_Count
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Count is the number of
--| spaces to be output to File_Handle. If Count is omitted, 1 is
--| assumed.
--| Effects:
--| Count number of line terminators are output to File_Handle.
--| If Count is greater than the number of lines remaining on
--| the page, the page footer, a page terminator, and the page header
--| are written before the remainder of the spaces are output.
--| If the specified Count is less than equal to 0, no operation
--| takes place.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If the requested space
--| count is greater than a predetermined amount, Invalid_Count
--| is raised. If an error occurs during output, Output_Error
--| is raised.
--| N/A: Modifies
pragma Page;
procedure Skip_Line(
Count : in NATURAL := 1
);
procedure Skip_Line( --| Output one or more spaces on a
--| paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output skips
Count : in NATURAL := 1
--| The number of spaces.
);
--| Raises:
--| Invalid_File, Output_Error, Invalid_Count
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Count is the number of
--| spaces to be output to File_Handle. If Count is omitted, 1 is
--| assumed.
--| Effects:
--| Count number of line terminators are output to File_Handle.
--| If Count is greater than the number of lines remaining on
--| the page, the page footer is printed, a page terminator is
--| output and the remainder of the skips are NOT output.
--| If the specified Count is less than equal to 0, no operation
--| takes place.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If the requested skip
--| count is greater than a predetermined amount, Invalid_Count
--| is raised. If an error occurs during output, Output_Error
--| is raised.
--| N/A: Modifies
pragma Page;
procedure Put_Page(
Count : in NATURAL := 1
);
procedure Put_Page( --| Output one or more page ejects
--| on a paginated file
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| output page ejects
Count : in NATURAL := 1
--| The number of pages.
);
--| Raises:
--| Invalid_File, Output_Error, Invalid_Count
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Count is the number of
--| pages to be output to File_Handle. If Count is omitted, 1 is
--| assumed.
--| Effects:
--| Outputs Count number of page ejects. The page footer and the page
--| header are printed as appropriate.
--| If the specified Count is less than equal to 0, no operation
--| takes place.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If the requested page
--| count is greater than a predetermined amount, Invalid_Count
--| is raised. If an error occurs during output, Output_Error
--| is raised.
--| N/A: Modifies
pragma Page;
function Available_Lines
return NATURAL;
function Available_Lines( --| Query the number of lines that
--| are available on the current page
File_Handle : in Paginated_File_Handle
--| The paginated file to be
--| queried for available lines
) return NATURAL;
--| Raises:
--| Invalid_File
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.
--| Effects:
--| Return the number of lines (excluding the header and the footer
--| spaces) remaining on the current output page.
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.
--| N/A: Modifies
pragma Page;
procedure Reserve_Lines(
Count : in NATURAL
);
procedure Reserve_Lines( --| Assure that there are at least
--| a specified number of contiguous
--| lines on a paginated file.
File_Handle : in Paginated_File_Handle;
--| The paginated file to
--| reserve the lines
Count : in NATURAL --| The number of lines needed
);
--| Raises :
--| Invalid_File, Page_Overflow
--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File. Count is the number of
--| contiguous lines needed on File_Handle.
--| Effects:
--| If Count is greater than the number of lines remaining on
--| the page, Put_Page is executed to assure that there are Count
--| number of contiguous lines.
--| Specifying value less than or equal to 0 for Count will result
--| in no operation
--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised. If Count is greater than
--| the maximum number of lines available on a page as set by
--| Set_Page_Layout, exception Page_Overflow is raised and Put_Page
--| is NOT executed.
pragma Page;
private
pragma List(off);
type Variable_String_Array_Handle is
access Variable_String_Array;
--| Handle to array of variable length
--| strings
type Paginated_File_Structure;
--| Data structure to store state of
--| the output file.
type Paginated_File_Handle is
access Paginated_File_Structure;
--| Handle to be passed around in a
--| program that uses paginated_output.
type Paginated_File_Structure is
--| a structure to store state of
record --| the output file.
access_count : NATURAL;
--| Number of accesses to this structure
forward_link : Paginated_File_Handle := null;
--| Access to next file structure
reverse_link : Paginated_File_Handle := null;
--| Access to previous file structure
file_spec : SP.String_Type;
--| External file name
file_name : SP.String_Type;
--| External file name for ~f substitute
file_reference : TIO.File_Type;
--| External file reference
output_mode : Paginated_Output_Mode := STD;
--| Output mode (STD or CUR)
page_size : NATURAL;
--| The number of lines per page
maximum_line : NATURAL;
--| The maximum number of text lines
current_calendar : SP.String_Type;
--| Creation date (eg. March 15, 1985)
current_date : STRING (1 .. 8);
--| Creation date (eg. 03/15/85)
current_time : STRING (1 .. 8);
--| Creation time (eg. 15:24:07)
current_page : NATURAL := 0;
--| The number of lines per page
current_line : NATURAL := 0;
--| The number of lines used
header_size : NATURAL;
--| Number of lines of header text
odd_page_header : Variable_String_Array_Handle := null;
--| Access to odd page header text
even_page_header : Variable_String_Array_Handle := null;
--| Access to even page header text
footer_size : NATURAL;
--| Number of lines of footer text
odd_page_footer : Variable_String_Array_Handle := null;
--| Access to odd page footer text
even_page_footer : Variable_String_Array_Handle := null;
--| Access to even page footer text
end record;
pragma List(on);
end Paginated_Output;
pragma Page;
--::::::::::
--pgfile.bdy
--::::::::::
with Calendar;
with Unchecked_Deallocation;
with String_Utilities;
package body Paginated_Output is
package IIO is new TIO.Integer_IO(INTEGER);
package CAL renames Calendar;
package SU renames String_Utilities;
package SS is new SU.Generic_String_Utilities(SP.String_Type,
SP.Make_Persistent,
SP.Value);
type Odd_Even is (Odd, Even); --| Odd/Even page indicator
type Header_Footer is (Header,Footer); --| Header/Footer selection
type Kind_Of_Text is --| Text selection switches
record
page: Odd_Even;
text: Header_Footer;
end record;
type DCT is (DATE, CALENDAR_DATE, TIME);
type Date_Calendar_Time is array (DCT) of BOOLEAN;
Max_Filename_Size : constant POSITIVE := 60;
Max_Calendar_Size : constant POSITIVE := 18;
Max_Page_Size : constant POSITIVE := 3;
Month_Name : constant Variable_String_Array(1 .. 12) :=
( 1 => SP.Create("January"),
2 => SP.Create("February"),
3 => SP.Create("March"),
4 => SP.Create("April"),
5 => SP.Create("May"),
6 => SP.Create("June"),
7 => SP.Create("July"),
8 => SP.Create("August"),
9 => SP.Create("September"),
10 => SP.Create("October"),
11 => SP.Create("November"),
12 => SP.Create("December") );
Paginated_Standard_Output : Paginated_File_Handle;
pragma page;
procedure Reset_Date_Calendar_Time(
File_Handle : in Paginated_File_Handle;
Reset : in Date_Calendar_Time
) is
--|-Algorithm:
--| Get the current system date/time
--| Separate date/time into appropriate components
--| Calculate in terms of hours, minutes, and seconds
--| Set current date/time in the file structure
--| Set the current date in "English" (eg. January 1, 1985)
--| in the file structure
--| Exit
--|+
Clock_Value : CAL.Time;
Year : CAL.Year_Number;
Month : CAL.Month_Number;
Day : CAL.Day_Number;
Duration : CAL.Day_Duration;
begin
Clock_Value := CAL.Clock;
CAL.Split(Clock_Value, Year, Month, Day, Duration);
if Reset(Date) then
File_Handle.current_date := SU.Image(INTEGER(Month), 2, '0') & "/"
& SU.Image(INTEGER(Day), 2, '0') & "/"
& SU.Image(INTEGER(Year mod 100), 2, '0');
end if;
if Reset(Time) then
File_Handle.current_time := SU.Image(INTEGER(Duration) / (60 * 60), 2, '0') & ":"
& SU.Image((INTEGER(Duration) mod (60 * 60)) / 60, 2, '0') & ":"
& SU.Image(INTEGER(Duration) mod 60, 2, '0');
end if;
if Reset(Calendar_Date) then
SP.Mark;
if not SP.Equal(File_Handle.current_calendar, "") then
SP.Flush(File_Handle.current_calendar);
end if;
File_Handle.current_calendar := SP.Make_Persistent(
SP.Value(Month_Name(INTEGER(Month))) &
INTEGER'image(Day) &
"," &
INTEGER'image(Year));
SP.Release;
end if;
return;
end Reset_Date_Calendar_Time;
pragma page;
procedure Check_Valid(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| If handle is null or external file name is null
--| then raise an error
--| Exit
--|+
begin
if File_Handle = null then
raise Invalid_File;
end if;
return;
end Check_Valid;
pragma page;
procedure Clear_Text(
Text_Handle : in Variable_String_Array_Handle
) is
--|-Algorithm:
--| If valid access to text array
--| then return text array storage to the heap (access set to null)
--| Exit
--|+
begin
if Text_Handle /= null then
for i in Text_Handle'range loop
SP.Flush(Text_Handle(i));
end loop;
end if;
return;
end Clear_Text;
procedure Set_Text(
File_Handle : in Paginated_File_Handle;
Text_String : in Variable_String_Array;
Text_Control : in Kind_Of_Text
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested text array is too large
--| then raise an error
--| Clear old text array
--| Set new text array with specified justification (top or bottom)
--| in the area as specified
--| Exit
--|+
Text_Handle : Variable_String_Array_Handle;
Text_Index : INTEGER;
Text_Size : INTEGER;
Handle : Paginated_File_Handle;
begin
Check_Valid(File_Handle);
Handle := File_Handle;
loop
exit when Handle = null;
case Text_Control.text is
when Header =>
Text_Size := Handle.header_size;
Text_Index := 1;
case Text_Control.page is
when Odd =>
Text_Handle := Handle.odd_page_header;
when Even =>
Text_Handle := Handle.even_page_header;
end case;
when Footer =>
Text_Size := Handle.footer_size;
Text_Index := Text_Size - Text_String'last + 1;
case Text_Control.page is
when Odd =>
Text_Handle := Handle.odd_page_footer;
when Even =>
Text_Handle := Handle.even_page_footer;
end case;
end case;
if Text_Size < Text_String'last then
raise Text_Overflow;
end if;
Clear_Text(Text_Handle);
for i in Text_String'range loop
Text_Handle(Text_Index) := SP.Make_Persistent(Text_String(i));
Text_Index := Text_Index + 1;
end loop;
Handle := Handle.forward_link;
end loop;
return;
end Set_Text;
pragma page;
procedure Substitute(
In_String : in SP.String_Type;
Index : in out INTEGER;
Sub_String : in STRING;
Out_String : out SP.String_Type
) is
Scanner : SU.Scanner;
S_Str : SP.String_Type;
Found : BOOLEAN;
Num : INTEGER;
Letter : CHARACTER;
Inx : INTEGER;
begin
Out_String := SP.Create(Sub_String);
Scanner := SS.Make_Scanner(
SP.Substr(In_String, Index, SP.Length(In_String) - Index + 1)
);
SS.Scan_Enclosed('(', ')', Scanner, Found, S_Str);
SU.Destroy_Scanner(Scanner);
if Found then
Scanner := SS.Make_Scanner(S_Str);
Inx := SP.Length(S_Str);
SP.Flush(S_Str);
if SU.More(Scanner) then
SU.Next(Scanner, Letter);
if SU.More(Scanner) then
SU.Scan_Number(Scanner, Found, Num);
if Found and then Num > 0 then
if not SU.More(Scanner) then
if Letter = 'r' or Letter = 'R' or
Letter = 'l' or Letter = 'L' or
Letter = 'c' or Letter = 'C' then
case Letter is
when 'R' | 'r' =>
Out_String := SS.Right_Justify(Sub_String, Num);
when 'L' | 'l' =>
Out_String := SS.Left_Justify(Sub_String, Num);
when 'C' | 'c' =>
Out_String := SS.Center(Sub_String, Num);
when others =>
null;
end case;
Index := Index + Inx + 2;
end if;
end if;
end if;
end if;
end if;
SU.Destroy_Scanner(Scanner);
end if;
end Substitute;
pragma page;
function Tilde_Substitute(
File_Handle : in Paginated_File_Handle;
Input_Text : in SP.String_Type
) return STRING is
--|-Algorithm:
--| Set the length of the text in question
--| Clear the result string to null
--| Loop until all input characters are processed
--| Fetch one character
--| If the character is a tilde (~)
--| then bump input index and if past the end exit the loop
--| Fetch the next character
--| Based on this character substitute appropriately
--| else add this to the output
--| Bump input index and loop
--| Return the output (substituted) string
--| Exit
--|+
Output_Text : SP.String_Type;
R_Str, S_Str : SP.String_Type;
Letter : CHARACTER;
Index : NATURAL;
begin
S_Str := Input_Text;
loop
Index := SP.Match_C(S_Str, '~');
if Index = 0 then
Output_Text := SP."&"(Output_Text, S_Str);
exit;
end if;
if Index > 1 then
Output_Text := SP."&"(Output_Text, SP.Substr(S_Str, 1, Index - 1));
end if;
if Index < SP.Length(S_Str) then
Letter := SP.Fetch(S_Str, Index + 1);
else
exit;
end if;
Index := Index + 2;
case Letter is
when 'f' | 'F' =>
Substitute(S_Str, Index, SP.Value(File_Handle.file_name), R_Str);
Output_Text := SP."&"(Output_Text, R_Str);
when 'c' | 'C' =>
Substitute(S_Str, Index, SP.Value(File_Handle.current_calendar), R_Str);
Output_Text := SP."&"(Output_Text, R_Str);
when 'd' | 'D' =>
Substitute(S_Str, Index, File_Handle.current_date, R_Str);
Output_Text := SP."&"(Output_Text, R_Str);
when 't' | 'T' =>
Substitute(S_Str, Index, File_Handle.current_time, R_Str);
Output_Text := SP."&"(Output_Text, R_Str);
when 'p' | 'P' =>
Substitute(S_Str, Index, STRING'(SU.Image(File_Handle.current_page, 0)), R_Str);
Output_Text := SP."&"(Output_Text, R_Str);
when others =>
Output_Text := SP."&"(Output_Text, ("" & Letter));
end case;
if Index > SP.Length(S_Str) then
exit;
end if;
S_Str := SP.Substr(S_Str, Index, SP.Length(S_Str) - Index + 1);
end loop;
return SP.Value(Output_Text);
end Tilde_Substitute;
pragma page;
procedure Put_Text(
File_Handle : in Paginated_File_Handle;
Text_Control : in Kind_Of_Text
) is
--|-Algorithm:
--| If access to text array is null
--| then write appropriate number of line terminators
--| exit
--| Loop over the depth of the text array
--| If text is null
--| then write line terminator
--| else resolve tilde substitution
--| write a line of text followed by a line terminator
--| Exit
--|+
Text_Handle : Variable_String_Array_Handle;
Text_Size : INTEGER;
begin
case Text_Control.text is
when Header =>
if File_Handle.header_size = 0 then
return;
end if;
Text_Size := File_Handle.header_size;
if File_Handle.current_page mod 2 = 0 then
Text_Handle := File_Handle.even_page_header;
else
Text_Handle := File_Handle.odd_page_header;
end if;
when Footer =>
if File_Handle.footer_size = 0 then
return;
end if;
Text_Size := File_Handle.footer_size;
if File_Handle.current_page mod 2 = 0 then
Text_Handle := File_Handle.even_page_footer;
else
Text_Handle := File_Handle.odd_page_footer;
end if;
end case;
if Text_Handle = null then
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.New_Line(TIO.Standard_Output,
TIO.POSITIVE_Count(Text_Size));
else
TIO.New_Line(TIO.Current_Output,
TIO.POSITIVE_Count(Text_Size));
end if;
else
TIO.New_Line(File_Handle.file_reference,
TIO.POSITIVE_Count(Text_Size));
end if;
return;
end if;
for i in 1 .. Text_Size loop
SP.Mark;
if SP.Is_Empty(Text_Handle(i)) then
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.New_Line(TIO.Standard_Output, 1);
else
TIO.New_Line(TIO.Current_Output, 1);
end if;
else
TIO.New_Line(File_Handle.file_reference, 1);
end if;
else
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.Put_Line(TIO.Standard_Output,
Tilde_Substitute(File_Handle, Text_Handle(i)));
else
TIO.Put_Line(TIO.Current_Output,
Tilde_Substitute(File_Handle, Text_Handle(i)));
end if;
else
TIO.Put_Line(File_Handle.file_reference,
Tilde_Substitute(File_Handle, Text_Handle(i)));
end if;
end if;
SP.Release;
end loop;
return;
end Put_Text;
pragma page;
procedure Free_Structure is
new Unchecked_Deallocation(Paginated_File_Structure, Paginated_File_Handle);
procedure Abort_Paginated_Output(
File_Handle : in out Paginated_File_Handle
) is
--|-Algorithm:
--| If given handle is null
--| return
--| Return header/footer text array storage to the heap
--| Close file
--| Return file structure storage to the heap
--| Exit
--|+
begin
if File_Handle = null then
return;
end if;
Clear_Text(File_Handle.odd_page_header);
Clear_Text(File_Handle.even_page_header);
Clear_Text(File_Handle.odd_page_footer);
Clear_Text(File_Handle.even_page_footer);
SP.Flush(File_Handle.current_calendar);
SP.Flush(File_Handle.file_name);
if not SP.Equal(File_Handle.file_spec, "") then
SP.Flush(File_Handle.file_spec);
TIO.Close(File_Handle.file_reference);
end if;
Free_Structure(File_Handle);
return;
exception
when TIO.Status_error =>
Free_Structure(File_Handle);
end Abort_Paginated_Output;
pragma page;
function Footer_Exist(
File_Handle : in Paginated_File_Handle
) return BOOLEAN is
Text_Handle : Variable_String_Array_Handle;
Text_Size : INTEGER;
begin
Text_Size := File_Handle.footer_size;
if Text_Size <= 0 then
return FALSE;
end if;
if File_Handle.current_page mod 2 = 0 then
Text_Handle := File_Handle.even_page_footer;
else
Text_Handle := File_Handle.odd_page_footer;
end if;
if Text_Handle = null then
return FALSE;
end if;
for i in 1 .. Text_Size loop
SP.Mark;
if not SP.Is_Empty(Text_Handle(i)) then
return TRUE;
end if;
SP.Release;
end loop;
return FALSE;
end Footer_Exist;
pragma page;
procedure Line_Feed(
File_Handle : in Paginated_File_Handle;
Count : in INTEGER
) is
--|-Algorithm:
--| If at top of the page
--| then write header
--| If the request count is 0
--| then return
--| If the request is greater than the remainder on the page
--| then write remainder number of new lines
--| decrement request by this amount
--| write footer
--| eject page and update page and line count
--| if more space needed
--| then recursively call self with count
--| else write requested number of new lines
--| update line count
--| Exit
--|+
Skip_Count : INTEGER;
Text_Kind : Kind_Of_Text;
begin
if File_Handle.current_line = 0 and File_Handle.page_size /= 0 then
File_Handle.current_line := 1;
File_Handle.current_page := File_Handle.current_page + 1;
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.Put(TIO.Standard_Output, ASCII.FF);
else
TIO.Put(TIO.Current_Output, ASCII.FF);
end if;
else
TIO.Put(File_Handle.file_reference, ASCII.FF);
end if;
Text_Kind.text := Header;
Put_Text(File_Handle, Text_Kind);
end if;
if Count <= 0 then
return;
end if;
Skip_Count := File_Handle.maximum_line - File_Handle.current_line + 1;
if Count >= Skip_Count and File_Handle.page_size /= 0 then
if Footer_Exist(File_Handle) then
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.New_Line(TIO.Standard_Output,
TIO.POSITIVE_Count(Skip_Count));
else
TIO.New_Line(TIO.Current_Output,
TIO.POSITIVE_Count(Skip_Count));
end if;
else
TIO.New_Line(File_Handle.file_reference,
TIO.POSITIVE_Count(Skip_Count));
end if;
Text_Kind.text := footer;
Put_Text(File_Handle, Text_Kind);
else
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.New_Line(TIO.Standard_Output, 1);
else
TIO.New_Line(TIO.Current_Output, 1);
end if;
else
TIO.New_Line(File_Handle.file_reference, 1);
end if;
end if;
Skip_Count := Count - Skip_Count;
File_Handle.current_line := 0;
if Skip_Count /= 0 then
Line_Feed(File_Handle, Skip_Count);
end if;
else
if SP.Equal(File_Handle.file_spec, "") then
if File_Handle.output_mode = STD then
TIO.New_Line(TIO.Standard_Output,
TIO.POSITIVE_Count(Count));
else
TIO.New_Line(TIO.Current_Output,
TIO.POSITIVE_Count(Count));
end if;
else
TIO.New_Line(File_Handle.file_reference,
TIO.POSITIVE_Count(Count));
end if;
if File_Handle.page_size /= 0 then
File_Handle.current_line := File_Handle.current_line + Count;
end if;
end if;
return;
end Line_Feed;
pragma page;
procedure Page_Eject(
File_Handle : in Paginated_File_Handle;
Count : in POSITIVE := 1
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Raise Invalid_Count if page request is too large
--| Convert the number of pages to skip into number of lines
--| Write out this number of new line control characters
--| while taking into account header, footer, and pagination.
--| Exit
--|+
begin
if File_Handle.page_size = 0 then
Line_Feed(File_Handle, 1);
return;
end if;
if Count > 99 then
raise Invalid_Count;
end if;
if File_Handle.current_line = 0 then
Line_Feed(File_Handle,
(Count * File_Handle.maximum_line));
else
Line_Feed(File_Handle,
(Count * File_Handle.maximum_line - File_Handle.current_line + 1));
end if;
return;
end Page_Eject;
pragma page;
procedure Set_Text_Area(
Text_Handle : in out Variable_String_Array_Handle;
Area_Size : in INTEGER
) is
Temp_Handle : Variable_String_Array_Handle;
begin
if Area_Size <= 0 then
return;
end if;
if Text_Handle = null or else
Text_Handle'last < Area_Size then
Temp_Handle := Text_Handle;
Text_Handle := new Variable_String_Array (1 .. Area_Size);
if Temp_Handle /= null then
for i in Temp_Handle'range loop
Text_Handle(i) := SP.Make_Persistent(Temp_Handle(i));
end loop;
Clear_Text(Temp_Handle);
end if;
end if;
end Set_Text_Area;
pragma page;
procedure Write(
File_Handle : in Paginated_File_Handle;
Text_Line : in STRING;
Feed : in BOOLEAN
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If at the top of the page
--| then write out the header
--| Output the given line of text to the paginated file
--| Write out a new line control character
--| If at the bottom of the page
--| then write out the footer and eject the page
--| Exit
--|+
Handle : Paginated_File_Handle;
begin
Check_Valid(File_Handle);
Handle := File_Handle;
loop
exit when Handle = null;
Line_Feed(Handle, 0);
if SP.Equal(Handle.file_spec, "") then
if Handle.output_mode = STD then
TIO.Put(TIO.Standard_Output, Text_Line);
else
TIO.Put(TIO.Current_Output, Text_Line);
end if;
else
TIO.Put(Handle.file_reference, Text_Line);
end if;
if Feed then
Line_Feed(Handle, 1);
end if;
Handle := Handle.forward_link;
end loop;
return;
end Write;
pragma page;
procedure Create_Paginated_File(
File_Name : in STRING := "";
File_Handle : in out Paginated_File_Handle;
Page_Size : in NATURAL := 66;
Header_Size : in NATURAL := 6;
Footer_Size : in NATURAL := 6;
Output_mode : in Paginated_output_mode := STD
) is
--|-Algorithm:
--| If an active (ie. non-null) handle is given
--| then close that file first
--| Create a paginated file structure
--| If no file name is given
--| then assume Standard output
--| else create (open) an external file
--| Fill the paginated file structure with external file information,
--| page layout information, and current date/time
--| Return access to the completed structure
--| Exit
--|+
begin
Close_Paginated_File(File_Handle);
File_Handle := new Paginated_File_Structure;
if File_Name /= "" then
File_Handle.file_spec := SP.Make_Persistent(File_Name);
TIO.Create(File => File_Handle.file_reference,
Name => File_Name);
end if;
Reset_File_Name(File_Handle);
Set_Page_Layout(File_Handle, Page_Size, Header_Size, Footer_Size);
Reset_Date_Calendar_Time(File_Handle, (Date=>TRUE, Calendar_Date=>TRUE, Time=>TRUE));
File_Handle.output_mode := output_mode;
File_Handle.access_count := 1;
return;
exception
when TIO.Status_error =>
Abort_Paginated_Output(File_Handle);
raise File_Already_Open;
when TIO.Name_error | TIO.Use_error =>
Abort_Paginated_Output(File_Handle);
raise File_error;
when Page_Layout_error =>
Abort_Paginated_Output(File_Handle);
raise Page_Layout_error;
end Create_Paginated_File;
pragma page;
procedure Set_Standard_Paginated_File(
File_Name : in STRING;
Page_Size : in NATURAL;
Header_Size : in NATURAL;
Footer_Size : in NATURAL
) is
begin
Create_Paginated_File(File_Name,
Paginated_Standard_Output,
Page_Size,
Header_Size,
Footer_Size);
end Set_Standard_Paginated_File;
pragma page;
procedure Duplicate_Paginated_File(
Old_Handle : in Paginated_File_Handle;
New_Handle : in out Paginated_File_Handle
) is
--|-Algorithm:
--| Close file refered to by the handle to which the existing handle
--| is to be copied (if such file exists)
--| Duplicate the handle
--| Exit
--|+
begin
Close_Paginated_File(New_Handle);
Old_Handle.access_count := Old_Handle.access_count + 1;
New_Handle := Old_Handle;
return;
end Duplicate_Paginated_File;
pragma page;
procedure Set_Page_Layout(
Page_Size : in NATURAL;
Header_Size : in NATURAL;
Footer_Size : in NATURAL
) is
begin
Set_Page_Layout(Paginated_Standard_Output,
Page_Size,
Header_Size,
Footer_Size);
end Set_Page_Layout;
procedure Set_Page_Layout(
File_Handle : in Paginated_File_Handle;
Page_Size : in NATURAL;
Header_Size : in NATURAL;
Footer_Size : in NATURAL
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If page layout is contradictory
--| then raise an error
--| If not at the top of the page
--| then eject current page
--| Set page size, header size, footer size, and text area size
--| per page
--| Exit
--|+
Temp_Handle : Variable_String_Array_Handle;
begin
Check_Valid(File_Handle);
if Page_Size < 0 or Header_Size < 0 or Footer_Size < 0 or
(Page_Size /= 0 and Page_Size <= Header_Size + Footer_Size) then
raise Page_Layout_error;
return;
end if;
if File_Handle.current_line /= 0 and File_Handle.page_size /= 0 then
Page_Eject(File_Handle, 1);
end if;
File_Handle.page_size := Page_Size;
if Page_Size = 0 then
File_Handle.maximum_line := 0;
else
File_Handle.maximum_line := Page_Size - (Header_Size + Footer_Size);
end if;
File_Handle.header_size := Header_Size;
Set_Text_Area(File_Handle.odd_page_header, File_Handle.header_size);
Set_Text_Area(File_Handle.even_page_header, File_Handle.header_size);
File_Handle.footer_size := Footer_Size;
Set_Text_Area(File_Handle.odd_page_footer, File_Handle.footer_size);
Set_Text_Area(File_Handle.even_page_footer, File_Handle.footer_size);
return;
end Set_Page_Layout;
pragma page;
procedure Link_Paginated_File(
File_Handle1 : in Paginated_File_Handle;
File_Handle2 : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle1);
Check_Valid(File_Handle2);
if File_Handle1.forward_link = null and
File_Handle2.reverse_link = null then
File_Handle1.forward_link := File_Handle2;
File_Handle2.reverse_link := File_Handle1;
return;
end if;
raise Files_Already_Linked;
end Link_Paginated_File;
procedure Unlink_Paginated_File(
File_Handle : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle);
if File_Handle.reverse_link /= null then
File_Handle.reverse_link.forward_link := File_Handle.forward_link;
File_Handle.reverse_link := null;
end if;
if File_Handle.forward_link /= null then
File_Handle.forward_link.reverse_link := File_Handle.reverse_link;
File_Handle.forward_link := null;
end if;
return;
end Unlink_Paginated_File;
pragma page;
procedure Set_File_Name(
File_Handle : in Paginated_File_Handle;
File_Name : in STRING
) is
begin
Check_Valid(File_Handle);
File_Handle.file_name := SP.Make_Persistent(File_Name);
end Set_File_Name;
procedure Set_File_Name(
File_Name : in STRING
) is
begin
Set_File_Name(Paginated_Standard_Output, File_Name);
end Set_File_Name;
procedure Reset_File_Name(
File_Handle : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle);
if not SP.Equal(File_Handle.file_name, "") then
SP.Flush(File_Handle.file_name);
end if;
if SP.Equal(File_Handle.file_spec, "") then
File_Handle.file_name := SP.Make_Persistent("STANDARD OUTPUT");
else
File_Handle.file_name := SP.Make_Persistent(File_Handle.file_spec);
end if;
end Reset_File_Name;
procedure Reset_File_Name
is
begin
Reset_File_Name(Paginated_Standard_Output);
end Reset_File_Name;
pragma page;
procedure Set_Date(
File_Handle : in Paginated_File_Handle;
Date : in Date_String
) is
S_Str : SP.String_Type;
begin
Check_Valid(File_Handle);
File_Handle.current_date := Date;
end Set_Date;
procedure Set_Date(
Date : in Date_String
) is
begin
Set_Date(Paginated_Standard_Output, Date);
end Set_Date;
procedure Reset_Date(
File_Handle : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle);
Reset_Date_Calendar_Time(File_Handle, (Date=>TRUE, Calendar_Date=> FALSE, Time=>FALSE));
end Reset_Date;
procedure Reset_Date
is
begin
Reset_Date(Paginated_Standard_Output);
end Reset_Date;
pragma page;
procedure Set_Calendar(
File_Handle : in Paginated_File_Handle;
Calendar : in STRING
) is
begin
Check_Valid(File_Handle);
File_Handle.current_Calendar := SP.Make_Persistent(Calendar);
end Set_Calendar;
procedure Set_Calendar(
Calendar : in STRING
) is
begin
Set_Calendar(Paginated_Standard_Output, Calendar);
end Set_Calendar;
procedure Reset_Calendar(
File_Handle : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle);
Reset_Date_Calendar_Time(File_Handle, (Date=>FALSE, Calendar_Date=> TRUE, Time=>FALSE));
end Reset_Calendar;
procedure Reset_Calendar
is
begin
Reset_Calendar(Paginated_Standard_Output);
end Reset_Calendar;
pragma page;
procedure Set_Time(
File_Handle : in Paginated_File_Handle;
Time : in Time_String
) is
begin
Check_Valid(File_Handle);
File_Handle.current_time := Time;
end Set_Time;
procedure Set_Time(
Time : in Time_String
) is
begin
Set_Time(Paginated_Standard_Output, Time);
end Set_Time;
procedure Reset_Time(
File_Handle : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle);
Reset_Date_Calendar_Time(File_Handle, (Date=>FALSE, Calendar_Date=> FALSE, Time=>TRUE));
end Reset_Time;
procedure Reset_Time
is
begin
Reset_Time(Paginated_Standard_Output);
end Reset_Time;
pragma page;
procedure Set_Page(
File_Handle : in Paginated_File_Handle;
Page : in POSITIVE
) is
begin
Check_Valid(File_Handle);
File_Handle.current_page := Page - 1;
end Set_Page;
procedure Set_Page(
Page : in POSITIVE
) is
begin
Set_Page(Paginated_Standard_Output, Page);
end Set_Page;
procedure Reset_Page(
File_Handle : in Paginated_File_Handle
) is
begin
Check_Valid(File_Handle);
File_Handle.current_page := 0;
end Reset_Page;
procedure Reset_Page
is
begin
Reset_Page(Paginated_Standard_Output);
end Reset_Page;
pragma page;
procedure Set_Header(
Header_Text : in Variable_String_Array
) is
begin
Set_Header(Paginated_Standard_Output,
Header_Text);
end Set_Header;
procedure Set_Header(
File_Handle : in Paginated_File_Handle;
Header_Text : in Variable_String_Array
) is
--|-Algorithm:
--| Set given header text as odd page header
--| Set given header text as even page header
--| Exit
--|+
begin
Set_Text(File_Handle, Header_Text, (Odd, Header));
Set_Text(File_Handle, Header_Text, (Even, Header));
return;
end Set_Header;
procedure Set_Header(
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
) is
begin
Set_Header(Paginated_Standard_Output,
Header_Line,
Header_Text);
end Set_Header;
procedure Set_Header(
File_Handle : in Paginated_File_Handle;
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
) is
--|-Algorithm:
--| Set odd page header
--| Set even page header
--| Exit
--|+
begin
Set_Odd_Header(File_Handle, Header_Line, Header_Text);
Set_Even_Header(File_Handle, Header_Line, Header_Text);
return;
end Set_Header;
procedure Set_Header(
Header_Line : in POSITIVE;
Header_Text : in STRING
) is
begin
Set_Header(Paginated_Standard_Output,
Header_Line,
Header_Text);
end Set_Header;
procedure Set_Header(
File_Handle : in Paginated_File_Handle;
Header_Line : in POSITIVE;
Header_Text : in STRING
) is
--|-Algorithm:
--| Create a variable string
--| Set odd page header
--| Set even page header
--| Exit
--|+
Text : SP.String_Type;
begin
Text := SP.Make_Persistent(Header_Text);
Set_Odd_Header(File_Handle, Header_Line, Text);
Set_Even_Header(File_Handle, Header_Line, Text);
SP.Flush(Text);
return;
end Set_Header;
pragma page;
procedure Set_Odd_Header(
Header_Text : in Variable_String_Array
) is
begin
Set_Odd_Header(Paginated_Standard_Output,
Header_Text);
end Set_Odd_Header;
procedure Set_Odd_Header(
File_Handle : in Paginated_File_Handle;
Header_Text : in Variable_String_Array
) is
--|-Algorithm:
--| Set given header text as odd page header
--| Exit
--|+
begin
Set_Text(File_Handle, Header_Text, (Odd, Header));
return;
end Set_Odd_Header;
procedure Set_Odd_Header(
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
) is
begin
Set_Odd_Header(Paginated_Standard_Output,
Header_Line,
Header_Text);
end Set_Odd_Header;
procedure Set_Odd_Header(
File_Handle : in Paginated_File_Handle;
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested header line number is out of range
--| then raise an error
--| Set header text at requested line for odd pages
--| Exit
--|+
begin
Check_Valid(File_Handle);
if Header_Line > File_Handle.header_size then
raise Text_Overflow;
end if;
File_Handle.odd_page_header(Header_Line) := SP.Make_Persistent(Header_Text);
return;
end Set_Odd_Header;
procedure Set_Odd_Header(
Header_Line : in POSITIVE;
Header_Text : in STRING
) is
begin
Set_Odd_Header(Paginated_Standard_Output,
Header_Line,
Header_Text);
end Set_Odd_Header;
procedure Set_Odd_Header(
File_Handle : in Paginated_File_Handle;
Header_Line : in POSITIVE;
Header_Text : in STRING
) is
--|-Algorithm:
--| Create a variable string
--| Set odd page header
--| Exit
--|+
Text : SP.String_Type;
begin
Text := SP.Make_Persistent(Header_Text);
Set_Odd_Header(File_Handle, Header_Line, Text);
SP.Flush(Text);
return;
end Set_Odd_Header;
pragma page;
procedure Set_Even_Header(
Header_Text : in Variable_String_Array
) is
begin
Set_Even_Header(Paginated_Standard_Output,
Header_Text);
end Set_Even_Header;
procedure Set_Even_Header(
File_Handle : in Paginated_File_Handle;
Header_Text : in Variable_String_Array
) is
--|-Algorithm:
--| Set given header text as even page header
--| Exit
--|+
begin
Set_Text(File_Handle, Header_Text, (Even, Header));
return;
end Set_Even_Header;
procedure Set_Even_Header(
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
) is
begin
Set_Even_Header(Paginated_Standard_Output,
Header_Line,
Header_Text);
end Set_Even_Header;
procedure Set_Even_Header(
File_Handle : in Paginated_File_Handle;
Header_Line : in POSITIVE;
Header_Text : in SP.String_Type
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested header line number is out of range
--| then raise an error
--| Set header text at requested line for even pages
--| Exit
--|+
begin
Check_Valid(File_Handle);
if Header_Line > File_Handle.header_size then
raise Text_Overflow;
end if;
SP.Flush(File_Handle.even_page_header(Header_Line));
File_Handle.even_page_header(Header_Line) := SP.Make_Persistent(Header_Text);
return;
end Set_Even_Header;
procedure Set_Even_Header(
Header_Line : in POSITIVE;
Header_Text : in STRING
) is
begin
Set_Even_Header(Paginated_Standard_Output,
Header_Line,
Header_Text);
end Set_Even_Header;
procedure Set_Even_Header(
File_Handle : in Paginated_File_Handle;
Header_Line : in POSITIVE;
Header_Text : in STRING
) is
--|-Algorithm:
--| Create a variable string
--| Set even page header
--| Exit
--|+
Text : SP.String_Type;
begin
Text := SP.Make_Persistent(Header_Text);
Set_Even_Header(File_Handle, Header_Line, Text);
SP.Flush(Text);
return;
end Set_Even_Header;
pragma page;
procedure Set_Footer(
Footer_Text : in Variable_String_Array
) is
begin
Set_Footer(Paginated_Standard_Output,
Footer_Text);
end Set_Footer;
procedure Set_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Text : in Variable_String_Array
) is
--|-Algorithm:
--| Set given footer text as odd page header
--| Set given footer text as even page header
--| Exit
--|+
begin
Set_Text(File_Handle, Footer_Text, (Odd, Footer));
Set_Text(File_Handle, Footer_Text, (Even, Footer));
return;
end Set_Footer;
procedure Set_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
) is
begin
Set_Footer(Paginated_Standard_Output,
Footer_Line,
Footer_Text);
end Set_Footer;
procedure Set_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
) is
--|-Algorithm:
--| Set odd page footer
--| Set even page footer
--| Exit
--|+
begin
Set_Odd_Footer(File_Handle, Footer_Line, Footer_Text);
Set_Even_Footer(File_Handle, Footer_Line, Footer_Text);
return;
end Set_Footer;
procedure Set_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in STRING
) is
begin
Set_Footer(Paginated_Standard_Output,
Footer_Line,
Footer_Text);
end Set_Footer;
procedure Set_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Line : in POSITIVE;
Footer_Text : in STRING
) is
--|-Algorithm:
--| Create a variable string
--| Set odd page footer
--| Set even page footer
--| Exit
--|+
Text : SP.String_Type;
begin
Text := SP.Make_Persistent(Footer_Text);
Set_Odd_Footer(File_Handle, Footer_Line, Text);
Set_Even_Footer(File_Handle, Footer_Line, Text);
SP.Flush(Text);
return;
end Set_Footer;
pragma page;
procedure Set_Odd_Footer(
Footer_Text : in Variable_String_Array
) is
begin
Set_Odd_Footer(Paginated_Standard_Output,
Footer_Text);
end Set_Odd_Footer;
procedure Set_Odd_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Text : in Variable_String_Array
) is
--|-Algorithm:
--| Set given footer text as odd page header
--| Exit
--|+
begin
Set_Text(File_Handle, Footer_Text, (Odd, Footer));
return;
end Set_Odd_Footer;
procedure Set_Odd_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
) is
begin
Set_Odd_Footer(Paginated_Standard_Output,
Footer_Line,
Footer_Text);
end Set_Odd_Footer;
procedure Set_Odd_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested footer line number is out of range
--| then raise an error
--| Set footer text at requested line for odd pages
--| Exit
--|+
begin
Check_Valid(File_Handle);
if Footer_Line > File_Handle.footer_size then
raise Text_Overflow;
end if;
SP.Flush(File_Handle.odd_page_footer(Footer_Line));
File_Handle.odd_page_footer(Footer_Line) := SP.Make_Persistent(Footer_Text);
return;
end Set_Odd_Footer;
procedure Set_Odd_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in STRING
) is
begin
Set_Odd_Footer(Paginated_Standard_Output,
Footer_Line,
Footer_Text);
end Set_Odd_Footer;
procedure Set_Odd_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Line : in POSITIVE;
Footer_Text : in STRING
) is
Text : SP.String_Type;
begin
Text := SP.Make_Persistent(Footer_Text);
Set_Odd_Footer(File_Handle, Footer_Line, Text);
SP.Flush(Text);
return;
end Set_Odd_Footer;
pragma page;
procedure Set_Even_Footer(
Footer_Text : in Variable_String_Array
) is
begin
Set_Even_Footer(Paginated_Standard_Output,
Footer_Text);
end Set_Even_Footer;
procedure Set_Even_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Text : in Variable_String_Array
) is
--|-Algorithm:
--| Set given footer text as even page header
--| Exit
--|+
begin
Set_Text(File_Handle, Footer_Text, (Even, Footer));
return;
end Set_Even_Footer;
procedure Set_Even_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
) is
begin
Set_Even_Footer(Paginated_Standard_Output,
Footer_Line,
Footer_Text);
end Set_Even_Footer;
procedure Set_Even_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Line : in POSITIVE;
Footer_Text : in SP.String_Type
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested footer line number is out of range
--| then raise an error
--| Set footer text at requested line for even pages
--| Exit
--|+
begin
Check_Valid(File_Handle);
if Footer_Line > File_Handle.footer_size then
raise Text_Overflow;
end if;
SP.Flush(File_Handle.even_page_footer(Footer_Line));
File_Handle.even_page_footer(Footer_Line) := SP.Make_Persistent(Footer_Text);
return;
end Set_Even_Footer;
procedure Set_Even_Footer(
Footer_Line : in POSITIVE;
Footer_Text : in STRING
) is
begin
Set_Even_Footer(Paginated_Standard_Output,
Footer_Line,
Footer_Text);
end Set_Even_Footer;
procedure Set_Even_Footer(
File_Handle : in Paginated_File_Handle;
Footer_Line : in POSITIVE;
Footer_Text : in STRING
) is
--|-Algorithm:
--| Create a variable string
--| Set even page footer
--| Exit
--|+
Text : SP.String_Type;
begin
Text := SP.Make_Persistent(Footer_Text);
Set_Even_Footer(File_Handle, Footer_Line, Text);
SP.Flush(Text);
return;
end Set_Even_Footer;
pragma page;
procedure Clear_Header
is
begin
Clear_Header(Paginated_Standard_Output);
end Clear_Header;
procedure Clear_Header(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| Clear odd page header
--| Clear even page header
--| Exit
--|+
begin
Clear_Odd_Header(File_Handle);
Clear_Even_Header(File_Handle);
return;
end Clear_Header;
pragma page;
procedure Clear_Odd_Header
is
begin
Clear_Odd_Header(Paginated_Standard_Output);
end Clear_Odd_Header;
procedure Clear_Odd_Header(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for odd page header lines
--| Exit
--|+
begin
Check_Valid(File_Handle);
Clear_Text(File_Handle.odd_page_header);
return;
end Clear_Odd_Header;
pragma page;
procedure Clear_Even_Header
is
begin
Clear_Even_Header(Paginated_Standard_Output);
end Clear_Even_Header;
procedure Clear_Even_Header(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for even page header lines
--| Exit
--|+
begin
Check_Valid(File_Handle);
Clear_Text(File_Handle.even_page_header);
return;
end Clear_Even_Header;
pragma page;
procedure Clear_Footer
is
begin
Clear_Footer(Paginated_Standard_Output);
end Clear_Footer;
procedure Clear_Footer(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| Clear odd page footer
--| Clear even page footer
--| Exit
--|+
begin
Clear_Odd_Footer(File_Handle);
Clear_Even_Footer(File_Handle);
return;
end Clear_Footer;
pragma page;
procedure Clear_Odd_Footer
is
begin
Clear_Odd_Footer(Paginated_Standard_Output);
end Clear_Odd_Footer;
procedure Clear_Odd_Footer(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for odd page footer lines
--| Exit
--|+
begin
Check_Valid(File_Handle);
Clear_Text(File_Handle.odd_page_footer);
return;
end Clear_Odd_Footer;
pragma page;
procedure Clear_Even_Footer
is
begin
Clear_Even_Footer(Paginated_Standard_Output);
end Clear_Even_Footer;
procedure Clear_Even_Footer(
File_Handle : in Paginated_File_Handle
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for even footer lines
--| Exit
--|+
begin
Check_Valid(File_Handle);
Clear_Text(File_Handle.even_page_footer);
return;
end Clear_Even_Footer;
pragma page;
procedure Close_Paginated_File
is
begin
Close_Paginated_File(Paginated_Standard_Output);
Create_Paginated_File("", Paginated_Standard_Output, 0, 0, 0);
end Close_Paginated_File;
procedure Close_Paginated_File(
File_Handle : in out Paginated_File_Handle
) is
--|-Algorithm:
--| If no file (ie. handle is null)
--| then return
--| Decrement access count to this file structure
--| If other accesses still exist for this structure
--| then null this handle and return
--| If not at the top of the page
--| then eject current page
--| Return all storage used for this file to the heap
--| Close the external file
--| Exit
--|+
begin
if File_Handle = null then
return;
end if;
File_Handle.access_count := File_Handle.access_count - 1;
if File_Handle.access_count > 0 then
File_Handle := null;
return;
end if;
Unlink_Paginated_File(File_Handle);
if File_Handle.current_line /= 0 and File_Handle.page_size /= 0 then
Page_Eject(File_Handle, 1);
end if;
Abort_Paginated_Output(File_Handle);
return;
end Close_Paginated_File;
pragma page;
procedure Put(
Text : in CHARACTER
) is
begin
Put(Paginated_Standard_Output,
Text);
end Put;
procedure Put(
File_Handle : in Paginated_File_Handle;
Text : in CHARACTER
) is
begin
Write(File_Handle, "" & Text, FALSE);
end Put;
procedure Put(
Text : in STRING
) is
begin
Write(Paginated_Standard_Output, Text, FALSE);
end Put;
procedure Put(
File_Handle : in Paginated_File_Handle;
Text : in STRING
) is
--|-Algorithm:
--| Execute Write procedure with feed
--| Exit
--|+
begin
Write(File_Handle, Text, FALSE);
end Put;
procedure Put(
Text : in SP.String_Type
) is
begin
Put(Paginated_Standard_Output,
SP.Value(Text));
end Put;
procedure Put(
File_Handle : in Paginated_File_Handle;
Text : in SP.String_Type
) is
--|-Algorithm:
--| Create a fixed length string
--| Output the line
--| Exit
--|+
begin
Put(File_Handle, SP.Value(Text));
return;
end Put;
procedure Put(
Text : in Variable_String_Array
) is
begin
for i in Text'range loop
Put(Paginated_Standard_Output, SP.Value(Text(i)));
end loop;
return;
end Put;
procedure Put(
File_Handle : in Paginated_File_Handle;
Text : in Variable_String_Array
) is
--|-Algorithm:
--| Loop for all elements of the variable string array
--| Create a fixed length string
--| Output the line
--| Exit
--|+
begin
for i in Text'range loop
Put(File_Handle, SP.Value(Text(i)));
end loop;
return;
end Put;
pragma page;
procedure Space(
Count : in NATURAL
) is
begin
Space(Paginated_Standard_Output,
Count);
end Space;
procedure Space(
File_Handle : in Paginated_File_Handle;
Count : in NATURAL
) is
begin
Check_Valid(File_Handle);
if Count = 0 then
return;
end if;
declare
Space_String : STRING (1 .. Count) := (1 .. Count => ' ');
begin
Put(File_Handle, Space_String);
end;
end Space;
pragma page;
procedure Put_Line(
Text_Line : in STRING
) is
begin
Write(Paginated_Standard_Output, Text_Line, TRUE);
end Put_Line;
procedure Put_Line(
File_Handle : in Paginated_File_Handle;
Text_Line : in STRING
) is
--|-Algorithm:
--| Execute Write procedure with feed
--| Exit
--|+
begin
Write(File_Handle, Text_Line, TRUE);
end Put_Line;
procedure Put_Line(
Text_Line : in SP.String_Type
) is
begin
Put_Line(Paginated_Standard_Output,
SP.Value(Text_Line));
return;
end Put_Line;
procedure Put_Line(
File_Handle : in Paginated_File_Handle;
Text_Line : in SP.String_Type
) is
--|-Algorithm:
--| Create a fixed length string
--| Output the line
--| Exit
--|+
begin
Put_Line(File_Handle, SP.Value(Text_Line));
return;
end Put_Line;
procedure Put_Line(
Text_Line : in Variable_String_Array
) is
begin
for i in Text_Line'range loop
Put_Line(Paginated_Standard_Output,
SP.Value(Text_Line(i)));
end loop;
return;
end Put_Line;
procedure Put_Line(
File_Handle : in Paginated_File_Handle;
Text_Line : in Variable_String_Array
) is
--|-Algorithm:
--| Loop for all elements of the variable string array
--| Create a fixed length string
--| Output the line
--| Exit
--|+
begin
for i in Text_Line'range loop
Put_Line(File_Handle, SP.Value(Text_Line(i)));
end loop;
return;
end Put_Line;
pragma page;
procedure Space_Line(
Count : in NATURAL := 1
) is
begin
Space_Line(Paginated_Standard_Output,
Count);
end Space_Line;
procedure Space_Line(
File_Handle : in Paginated_File_Handle;
Count : in NATURAL := 1
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Raise Invalid_Count if space request is too large
--| Write out the given number of new line control characters
--| while taking into account header, footer, and pagination.
--| Exit
--|+
Handle : Paginated_File_Handle;
begin
Check_Valid(File_Handle);
if Count = 0 then
return;
end if;
Handle := File_Handle;
loop
exit when Handle = null;
Line_Feed(Handle, Count);
Handle := Handle.forward_link;
end loop;
return;
end Space_Line;
pragma page;
procedure Skip_Line(
Count : in NATURAL := 1
) is
begin
Skip_Line(Paginated_Standard_Output,
Count);
end Skip_Line;
procedure Skip_Line(
File_Handle : in Paginated_File_Handle;
Count : in NATURAL := 1
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Set the number of new line characters to be written as the
--| number specified or the number of lines remaining on the
--| page which ever is smaller.
--| Write out this number of new line control characters
--| while taking into account header, footer, and pagination.
--| (If at the top of the page then Skip_Lines does nothing)
--| Exit
--|+
Skip_Count : INTEGER;
Handle : Paginated_File_Handle;
begin
Check_Valid(File_Handle);
if Count = 0 then
return;
end if;
Handle := File_Handle;
loop
exit when Handle = null;
if Handle.current_line /= 0 or Handle.page_size = 0 then
Skip_Count := Handle.maximum_line - Handle.current_line + 1;
if Skip_Count > Count or Handle.page_size = 0 then
Skip_Count := Count;
end if;
Line_Feed(Handle, Skip_Count);
end if;
Handle := Handle.forward_link;
end loop;
return;
end Skip_Line;
pragma page;
procedure Put_Page(
Count : in NATURAL := 1
) is
begin
Put_Page(Paginated_Standard_Output,
Count);
end Put_Page;
procedure Put_Page(
File_Handle : in Paginated_File_Handle;
Count : in NATURAL := 1
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Raise Invalid_Count if page request is too large
--| Convert the number of pages to skip into number of lines
--| Write out this number of new line control characters
--| while taking into account header, footer, and pagination.
--| Exit
--|+
Handle : Paginated_File_Handle;
begin
Check_Valid(File_Handle);
if Count = 0 then
return;
end if;
Handle := File_Handle;
loop
exit when Handle = null;
Page_Eject(Handle, Count);
Handle := Handle.forward_link;
end loop;
return;
end Put_Page;
pragma page;
function Available_Lines
return NATURAL is
begin
return Available_Lines(Paginated_Standard_Output);
end Available_Lines;
function Available_Lines(
File_Handle : in Paginated_File_Handle
) return NATURAL is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Return the number of lines remaining on the page
--|+
begin
Check_Valid(File_Handle);
if File_Handle.page_size = 0 then
return 0;
end if;
if File_Handle.current_line = 0 then
return File_Handle.maximum_line;
else
return File_Handle.maximum_line - File_Handle.current_line + 1;
end if;
end Available_Lines;
pragma page;
procedure Reserve_Lines(
Count : in NATURAL
) is
begin
Reserve_Lines(Paginated_Standard_Output,
Count);
end Reserve_Lines;
procedure Reserve_Lines(
File_Handle : in Paginated_File_Handle;
Count : in NATURAL
) is
--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If the requested number of lines is greater than the page size
--| then raise an error
--| If the requested is greater than the remaining space
--| then eject page
--| Exit
--|+
begin
Check_Valid(File_Handle);
if Count = 0 or File_Handle.page_size = 0 then
return;
end if;
if Count > File_Handle.page_size then
raise Page_Overflow;
end if;
if Count > Available_Lines(File_Handle) then
Page_Eject(File_Handle, 1);
end if;
return;
end Reserve_Lines;
pragma page;
begin
Create_Paginated_File("", Paginated_Standard_Output, 0, 0, 0);
end Paginated_Output;
pragma page;
--::::::::::
--sutils.spc
--::::::::::
with String_Pkg;
with Stack_Pkg;
with String_Lists;
package String_Utilities is
--| Functions for scanning tokens from strings.
pragma page;
--| Overview
--| This package provides a set of functions used to scan tokens from
--| strings. After the function make_Scanner is called to convert a string
--| into a string Scanner, the following functions may be called to scan
--| various tokens from the string:
--|-
--| Make_Scanner Given a string returns a Scanner
--| Make_Scanner* Given a string returns a Scanner
--| More Return TRUE iff unscanned characters remain
--| Forward Bump the Scanner
--| Backward Bump back the Scanner
--| Get Return character
--| Next Return character and bump the Scanner
--| Get_String* Return Generic_String_Type in Scanner
--| Get_Remainder* Return Generic_String_Type in Scanner from current Index
--| Get_Segment* Return Generic_String_Type in Scanner as specified
--| Mark Mark the current Index for Restore
--| Unmark Remove the previous mark from the Scanner
--| Restore Restore the previously marked Index
--| Position Return the current position of the Scanner
--| Destroy_Scanner Free storage used by Scanner
--| Is_Word Return TRUE iff Scanner is at a non-blank character
--| Scan_Word* Return sequence of non blank characters
--| Is_Number Return TRUE iff Scanner is at a digit
--| Scan_Number* Return sequence of decimal digits
--| Scan_Number Return integer number
--| Is_Signed_Number Return TRUE iff Scanner is at a digit or sign
--| Scan_Signed_Number* Return sequence of decimal digits with optional sign (+/-)
--| Scan_Signed_Number Return integer number
--| Is_Space Return TRUE iff Scanner is at a space or tab
--| Scan_Space* Return sequence of spaces or tabs
--| Skip_Space Advance Scanner past white space
--| Is_Ada_Id Return TRUE iff Scanner is at first character of a possible Ada id
--| Scan_Ada_Id* Scan up to the character which are valid Ada identifier
--| Is_Quoted Return TRUE iff Scanner is at a double quote
--| Scan_Quoted* Scan quoted string, embedded quotes doubled
--| Is_Enclosed Return TRUE iff Scanner is at an enclosing character
--| Scan_Enclosed* Scan enclosed string, embedded enclosing character doubled
--| Is_Sequence Return TRUE iff Scanner is at some character in sequence
--| Is_Sequence* Return TRUE iff Scanner is at some character in sequence
--| Scan_Sequenc* (2) Scan user specified sequence of chars
--| Is_Not_Sequence Return TRUE iff Scanner is not at the characters in sequence
--| Is_Not_Sequence* Return TRUE iff Scanner is not at the characters in sequence
--| Scan_Not_Sequence* (2)
--| Scan string up to but not including a given sequence of chars
--| Is_Literal Return TRUE iff Scanner is at literal
--| Is_Literal* Return TRUE iff Scanner is at literal
--| Scan_Literal* (2) Scan user specified literal
--| Is_Not_Literal Return TRUE iff Scanner is not a given literal
--| Is_Not_Literal* Return TRUE iff Scanner is not a given literal
--| Scan_Not_Literal* (2)
--| Scan string up to but not including a given literal
--| Strip_Leading Strip leading characters from a given string
--| Strip_Leading* (3) Strip leading characters from a given string
--| Strip_Trailing Strip trailing characters from a given string
--| Strip_Trailing* (3) Strip trailing characters from a given string
--| Strip Strip both leading and trailing characters
--| Strip* (3) Strip both leading and trailing characters
--| Left_Justify Left justify a given string
--| Left_Justify* (3) Left justify a given string
--| Right_Justify Right justify a given string
--| Right_Justify* (3) Right justify a given string
--| Center Center a given string
--| Center* (3) Center a given string
--| Expand Fill and justify a given string
--| Expand* (3) Fill and justify a given string
--| Format Format a given string
--| Format* Format a given string
--| Image Convert an integer to a string
--| Image* Convert an integer to a string
--| Value Convert a string to an integer
--| Value* Convert a string to an integer
--| Match Return TRUE if a string matches another
--| Match* (3) Return TRUE if a string matches another
--|
--| nb : Operations followed by an asterisk (*) are generic operations
--|+
pragma page;
----------------------------------------------------------------
White_Space : constant STRING := " " & ASCII.HT;
Number : constant STRING := "0123456789";
Alphabetic : constant STRING := "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
Alphameric : constant STRING := Alphabetic & Number;
----------------------------------------------------------------
package SL renames String_Lists;
package SP renames String_Pkg;
----------------------------------------------------------------
type Scanner is private; --| Scanner type
type Justification_Mode is (NONE, LEFT, RIGHT, CENTER, EXPAND);
----------------------------------------------------------------
Out_Of_Bounds : exception; --| Raised when a operation is attempted on a
--| Scanner that has passed the end
Scanner_Not_Marked : exception; --| Raised when a Unmark or Restore is attemped
--| on a Scanner that has not been marked
Non_Numeric_String : exception; --| Raised when an attempt is made to take the
--| value of a string that is not a number
Number_Too_Large : exception; --| Raised when an attempt is made to scan a
--| number outside the implemented range
pragma page;
----------------------------------------------------------------
function Make_Scanner( --| Construct a Scanner from S.
S : in STRING --| String to be scanned.
) return Scanner;
--| Effects: Construct a Scanner from S.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function More( --| Check if Scanner is exhausted
T : in Scanner --| Scanner to check
) return BOOLEAN;
--| Effects: Return TRUE iff additional characters remain to be scanned.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Forward( --| Bump scanner
T : in Scanner --| Scanner
);
--| Effects: Update the scanner position.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Backward( --| Bump back scanner
T : in Scanner --| Scanner
);
--| Effects: Update the scanner position.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get( --| Return character
T : in Scanner --| Scanner to check
) return CHARACTER;
--| Raises: Out_Of_Bounds
--| Effects: Return character at the current Scanner position.
--| The scanner position remains unchanged.
--| N/A: Modifies, Errors
pragma page;
----------------------------------------------------------------
procedure Next( --| Return character and bump scanner
T : in Scanner; --| Scanner to check
C : out CHARACTER --| Character to be returned
);
--| Raises: Out_Of_Bounds
--| Effects: Return character at the current Scanner position and update
--| the position.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Position( --| Return current Scanner position
T : in Scanner --| Scanner to check
) return POSITIVE;
--| Raises: Out_Of_Bounds
--| Effects: Return a positive integer indicating the current Scanner position,
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Mark(
T : in Scanner
);
--| Effects: Mark the current index for possible future use
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Unmark(
T : in Scanner
);
--| Raises: Scanner_Not_Marked
--| Effects: removes previous mark from the scanner without change to the index
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Restore(
T : in Scanner
);
--| Raises: Scanner_Not_Marked
--| Effects: Restore the index to the previously marked value
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Destroy_Scanner( --| Free Scanner storage
T : in out Scanner --| Scanner to be freed
);
--| Effects: Free space occupied by the Scanner.
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Number( --| Return TRUE iff Scanner is at a decimal digit
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff Scan_Number would return a non-null string.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Number( --| Scan sequence of digits
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff one or more digits found
Result : out INTEGER; --| Number scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Signed_Number( --| Check if Scanner is at a decimal digit or
--| sign (+/-)
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff Scan_Signed_Number would return a non-null string.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Signed_Number( --| Scan signed sequence of digits
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff one or more digits found
Result : out INTEGER; --| Number scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE, Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Word( --| Check if Scanner is at the start of a word.
T : in Scanner --| Scanner to check
) return BOOLEAN;
--| Effects: Return TRUE iff Scanner is at the start of a word.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Space( --| Check if T is at a space or tab
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff Scan_Space would return a non-null string.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Skip_Space( --| Skip white space
T : in Scanner --| String to be scanned
);
--| Effects: Scan T past all white space (spaces and tabs).
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Ada_Id( --| Check if T is at an Ada identifier
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff Scan_Ada_Id would return a non-null string.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Quoted( --| Check if T is at a double quote
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is at a quoted string (eg. ... "Hello" ...).
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Enclosed( --| Check if T is at an enclosing character
B : in CHARACTER; --| Enclosing open character
E : in CHARACTER; --| Enclosing close character
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T as encosed by B and E (eg. ... [ABC] ...).
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Sequence( --| Check if T is at some sequence characters
Chars : in STRING; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is at some character of Chars.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Not_Sequence( --| Check if T is at some sequence of characters
Chars : in STRING; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is not at some character of Chars.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Literal( --| Check if T is at literal Chars
Chars : in STRING; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is at literal Chars.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Not_Literal( --| Check if T is not at literal Chars
Chars : in STRING; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is not at literal Chars
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Strip_Leading( --| Strip leading characters from a given string
Text : in STRING; --| Input string
Char : in STRING := " " & ASCII.HT
--| Character(s) to be stripped
) return STRING; --| Result string
--| Effects: The specified leading characters are stripped from the input text
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip_Trailing( --| Strip trailing characters from a given string
Text : in STRING; --| Input string
Char : in STRING := " " & ASCII.HT
--| Character(s) to be stripped
) return STRING; --| Result string
--| Effects: The given trailing characters are stripped from the input text
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip( --| Strip both leading and trailing characters
--| from a given string
Text : in STRING; --| Input string
Char : in STRING := " " & ASCII.HT
--| Character(s) to be stripped
) return STRING; --| Result string
--| Effects: The specified characters are stripped from the input text in both
--| leading and trailing positions
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Left_Justify( --| Left justify a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return STRING; --| Result string
--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Right_Justify( --| Right justify a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return STRING; --| Result string
--| Effects: The specified input string is placed right justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Center( --| Center a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return STRING; --| Result string
--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Expand( --| Expand a given string to Len
Text : in STRING; --| Input string
Len : in POSITIVE --| Output string length
) return STRING; --| Result string
--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand this string to 40 chars")
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Format( --| Format a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Length of each folded line
Del : in CHARACTER := ' ';
--| Delimiting character
Justify : in Justification_Mode := NONE
--| Justification mode
) return SL.List;
--| Effects: The specified string is folded into as many lines of Len as needed.
--| The character Del indicated an element of the input string where the
--| line may be "broken". Returned list consists of persistent string types
--| thus must be flushed (or DestroyDeep with Flush).
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Image( --| Convert an integer to a string
Num : in INTEGER; --| Input number
Len : in NATURAL := 0; --| Length of the output string
Fill : in CHARACTER := ' ' --| Fill character
) return STRING;
--| Effects: The specified integer is converted into a string of length Len.
--| Len of 0 implies that the converted integer fills the string.
--| If Len (other thatn 0) is too small to contain the converted string
--| the number is truncated.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Value( --| Convert a string to an integer
Text : in STRING --| String to be converted
) return INTEGER;
--| Raises: Non_Numeric_String, Number_Too_Large
--| Effects: The specified string is converted into an equivalent integer.
--| The string must have the syntax of an Ada INTEGER (LRM 2.4.1)
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Match( --| Match two strings
Pattern : in STRING; --| String to match
Target : in STRING; --| String to be searched
Wildcard : in CHARACTER := '*';
--| Wildcard character
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
--| Case sensitivity in comparison
) return BOOLEAN;
--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target. If Target satisfies the condition in Pattern
--| returns TRUE.
--| (eg. Match("A*B*", "AzzzBzzz") will return TRUE
--| Match("A*B*", "zzzABzzz") will return FALSE)
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
pragma page;
generic
type Generic_String_Type is private;
with function To_Generic (X : in STRING) return Generic_String_Type;
with function From_Generic (X : in Generic_String_Type) return STRING;
package Generic_String_Utilities is
----------------------------------------------------------------
function Make_Scanner( --| Construct a Scanner from S.
S : in Generic_String_Type --| String to be scanned.
) return Scanner;
--| Effects: Construct a Scanner from S.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get_String( --| Return contents of Scanner
T : in Scanner --| Scanner
) return Generic_String_Type;
--| Effects: Return a Generic_String_Type corresponding to the contents
--| of the Scanner
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get_Remainder( --| Return contents of Scanner from index
T : in Scanner
) return Generic_String_Type;
--| Effects: Return a Generic_String_Type starting at the current index
--| of the Scanner
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get_Segment( --| Return contents of Scanner
T : in Scanner; --| Scanner
From : in POSITIVE; --| Starting position
To : in POSITIVE --| Ending position
) return Generic_String_Type;
--| Effects: Return a Generic_String_Type corresponding to the contents
--| of the Scanner starting at From and end at but NOT including To.
--| (eg. Given a scanner T that contains : $123.45
--| Get_Segment(T, 2, 5) will return a Generic_String_Type containing 123
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Word( --| Scan sequence of non blank characters
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a word found
Result : out Generic_String_Type;--| Word scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of non blank
--| characters. If at least one is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
pragma page;
procedure Scan_Number( --| Scan sequence of digits
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff one or more digits found
Result : out Generic_String_Type;--| Number scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Signed_Number( --| Scan signed sequence of digits
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff one or more digits found
Result : out Generic_String_Type;--| Number scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Space( --| Scan sequence of white space characters
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff space found
Result : out Generic_String_Type --| Spaces scanned from string
);
--| Effects: Scan T past all white space (spaces
--| and tabs. If at least one is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
procedure Scan_Ada_Id( --| Scan Ada identifier
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff an Ada identifier found
Result : out Generic_String_Type;--| Identifier scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a valid Ada identifier.
--| If one is found, return Found => TRUE, Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Quoted( --| Scan a quoted string
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a quoted string found
Result : out Generic_String_Type;--| Quoted string scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan at T for an opening quote
--| followed by a sequence of characters and ending with a closing
--| quote. If successful, return Found => TRUE, Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| A pair of quotes within the quoted string is converted to a single quote.
--| The outer quotes are stripped.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Enclosed( --| Scan an enclosed string
B : in CHARACTER; --| Enclosing open character
E : in CHARACTER; --| Enclosing close character
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a quoted string found
Result : out Generic_String_Type;--| Quoted string scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan at T for an enclosing character
--| followed by a sequence of characters and ending with an enclosing character.
--| If successful, return Found => TRUE, Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| The enclosing characters are stripped.
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Sequence( --| Check if T is at some sequence characters
Chars : in Generic_String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is at some character of Chars.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Sequence( --| Scan arbitrary sequence of characters
Chars : in Generic_String_Type;--| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Result : out Generic_String_Type;--| Sequence scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C appears in
--| Char. If at least one is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Sequence( --| Scan arbitrary sequence of characters
Chars : in STRING; --| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Result : out Generic_String_Type;--| Sequence scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C appears in
--| Char. If at least one is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Not_Sequence( --| Check if T is not at some seuqnce of character
Chars : in Generic_String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is not at some character of Chars.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Sequence( --| Scan arbitrary sequence of characters
Chars : in Generic_String_Type;--| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Result : out Generic_String_Type;--| Sequence scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C does not appear
--| in Chars. If at least one such C is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Sequence( --| Scan arbitrary sequence of characters
Chars : in STRING; --| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Result : out Generic_String_Type;--| Sequence scanned from string
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C does not appear
--| in Chars. If at least one such C is found, return Found => TRUE,
--| Result => .
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Literal( --| Check if T is at literal Chars
Chars : in Generic_String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is at literal Chars.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Literal( --| Scan arbitrary literal
Chars : in STRING; --| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char matches the sequence
--| of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Literal( --| Scan arbitrary literal
Chars : in Generic_String_Type;--| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char matches the sequence
--| of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Is_Not_Literal( --| Check if T is not at literal Chars
Chars : in Generic_String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return BOOLEAN;
--| Effects: Return TRUE iff T is not at literal Chars
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Literal( --| Scan arbitrary literal
Chars : in STRING; --| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Result : out Generic_String_Type;--| String up to literal
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Literal( --| Scan arbitrary literal
Chars : in Generic_String_Type;--| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out BOOLEAN; --| TRUE iff a sequence found
Result : out Generic_String_Type;--| String up to literal
Skip : in BOOLEAN := FALSE --| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| N/A: Raises, Modifies, Errors
pragma page;
----------------------------------------------------------------
function Strip_Leading( --| Strip leading characters from a given string
Text : in Generic_String_Type; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return STRING; --| Result string
--| Effects: The specified leading characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip_Leading( --| Strip leading characters from a given string
Text : in STRING; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return Generic_String_Type; --| Result string
--| Effects: The specified leading characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip_Leading( --| Strip leading characters from a given string
Text : in Generic_String_Type; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return Generic_String_Type; --| Result string
--| Effects: The specified leading characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Strip_Trailing( --| Strip trailing characters from a given string
Text : in Generic_String_Type; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return STRING; --| Result string
--| Effects: The specified trailing characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip_Trailing( --| Strip trailing characters from a given string
Text : in STRING; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return Generic_String_Type; --| Result string
--| Effects: The specified trailing characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip_Trailing( --| Strip trailing characters from a given string
Text : in Generic_String_Type; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return Generic_String_Type; --| Result string
--| Effects: The specified trailing characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Strip( --| Strip both leading and trailing
--| characters from a given string
Text : in Generic_String_Type; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return STRING; --| Result string
--| Effects: The specified characters if any are stripped from the input text
--| in both leading and trailing positions.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip( --| Strip both leading and trailing
--| characters from a given string
Text : in STRING; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return Generic_String_Type; --| Result string
--| Effects: The specified characters if any are stripped from the input text
--| in both leading and trailing positions.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Strip( --| Strip both leading and trailing
--| characters from a given string
Text : in Generic_String_Type; --| Input string
Char : in STRING := " " & ASCII.HT --| Character(s) to be stripped
) return Generic_String_Type; --| Result string
--| Effects: The specified characters if any are stripped from the input text
--| in both leading and trailing positions.
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Left_Justify( --| Left justify a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return STRING; --| Result string
--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Left_Justify( --| Left justify a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Left_Justify( --| Left justify a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Right_Justify( --| Right justify a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return STRING; --| Result string
--| Effects: The specified input string is placed right justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Right_Justify( --| Right justify a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Right_Justify( --| Right justify a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Center( --| Center a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return STRING; --| Result string
--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Center( --| Center a given string
Text : in STRING; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Center( --| Center a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Output string length
Char : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Expand( --| Expand a given string to Len
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE --| Output string length
) return STRING; --| Result string
--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand this string to 40 chars")
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Expand( --| Expand a given string to Len
Text : in STRING; --| Input string
Len : in POSITIVE --| Output string length
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand this string to 40 chars")
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Expand( --| Expand a given string to Len
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE --| Output string length
) return Generic_String_Type; --| Result string
--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand this string to 40 chars")
--| N/A: Modifies, Raises, Errors
pragma page;
----------------------------------------------------------------
function Format( --| Format a given string
Text : in Generic_String_Type; --| Input string
Len : in POSITIVE; --| Length of each folded line
Del : in CHARACTER := ' '; --| Delimiting character
Justify : in Justification_Mode := NONE
--| Justification mode
) return SL.List;
--| Effects: The specified string is folded into as many lines of Len as needed.
--| The character Del indicated an element of the input string where the
--| line may be "broken". Returned list consists of persistent string types
--| thus must be flushed (or DestroyDeep with Flush).
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Image( --| Convert an integer to a string
Num : in INTEGER; --| Input number
Len : in NATURAL := 0; --| Length of the output string
Fill : in CHARACTER := ' ' --| Fill character
) return Generic_String_Type;
--| Effects: The specified integer is converted into a string of length Len.
--| Len of 0 implies that the converted integer fills the string.
--| If Len (other thatn 0) is too small to contain the converted string
--| the number is truncated.
--| N/A: Modifies, Raises, Errors
----------------------------------------------------------------
function Value( --| Convert a string to an integer
Text : in Generic_String_Type --| Input string
) return INTEGER;
--| Raises: Non_Numeric_String, Number_Too_Large
--| Effects: The specified string is converted into an equivalent integer.
--| The string must have the syntax of an Ada INTEGER (LRM 2.4.1)
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Match( --| Match two strings
Pattern : in Generic_String_Type;
--| String to match
Target : in STRING; --| String to be searched
Wildcard : in CHARACTER := '*';
--| Wildcard character
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
--| Case sensitivity in comparison
) return BOOLEAN;
--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target. If Target satisfies the condition in Pattern
--| returns TRUE.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Match( --| Match two strings
Pattern : in STRING; --| String to match
Target : in Generic_String_Type;
--| String to be searched
Wildcard : in CHARACTER := '*';
--| Wildcard character
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
--| Case sensitivity in comparison
) return BOOLEAN;
--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target. If Target satisfies the condition in Pattern
--| returns TRUE.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Match( --| Match two strings
Pattern : in Generic_String_Type;
--| String to match
Target : in Generic_String_Type;
--| String to be searched
Wildcard : in CHARACTER := '*';
--| Wildcard character
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
--| Case sensitivity in comparison
) return BOOLEAN;
--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target. If Target satisfies the condition in Pattern
--| returns TRUE.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
end Generic_String_Utilities;
private
pragma List(off);
package ST is new Stack_Pkg(POSITIVE);
type Scan_Record is
record
text : SP.String_Type; --| Copy of string being scanned
index : POSITIVE := 1; --| Current position of Scanner
mark : ST.Stack := ST.Create;
--| Marks
end record;
type Scanner is access Scan_Record;
pragma List(on);
end String_Utilities;
pragma page;
--::::::::::
--sutils.bdy
--::::::::::
with Unchecked_Deallocation;
package body String_Utilities is
----------------------------------------------------------------
procedure Free_Scanner is
new Unchecked_Deallocation(Scan_Record, Scanner);
----------------------------------------------------------------
function Is_Valid(
T : in Scanner
) return BOOLEAN is
begin
return T /= null;
end Is_Valid;
----------------------------------------------------------------
function Make_Scanner(
S : in STRING
) return Scanner is
T : Scanner := new Scan_Record;
begin
T.text := SP.Make_Persistent(S);
return T;
end Make_Scanner;
----------------------------------------------------------------
procedure Destroy_Scanner(
T : in out Scanner
) is
begin
if Is_Valid(T) then
SP.Flush(T.text);
ST.Destroy(T.mark);
Free_Scanner(T);
end if;
end Destroy_Scanner;
----------------------------------------------------------------
function More(
T : in Scanner
) return BOOLEAN is
begin
if Is_Valid(T) and then T.index <= SP.Length(T.text) then
return TRUE;
else
return FALSE;
end if;
end More;
----------------------------------------------------------------
function Get(
T : in Scanner
) return CHARACTER is
begin
if not More(T) then
raise Out_Of_Bounds;
end if;
return SP.Fetch(T.text, T.index);
end Get;
----------------------------------------------------------------
procedure Forward(
T : in Scanner
) is
begin
if Is_Valid(T) then
if SP.Length(T.text) >= T.index then
T.index := T.index + 1;
end if;
end if;
end Forward;
----------------------------------------------------------------
procedure Backward(
T : in Scanner
) is
begin
if Is_Valid(T) then
if T.index > 1 then
T.index := T.index - 1;
end if;
end if;
end Backward;
----------------------------------------------------------------
procedure Next(
T : in Scanner;
C : out CHARACTER
) is
begin
C := Get(T);
T.index := T.index + 1;
end Next;
----------------------------------------------------------------
function Position(
T : in Scanner
) return POSITIVE is
begin
if not More(T) then
raise Out_Of_Bounds;
end if;
return T.index;
end Position;
----------------------------------------------------------------
procedure Mark(
T : in Scanner
) is
begin
if Is_Valid(T) then
ST.Push(T.mark, T.index);
end if;
end Mark;
----------------------------------------------------------------
procedure Unmark(
T : in Scanner
) is
Num : POSITIVE;
begin
if Is_Valid(T) and then not ST.Is_Empty(T.mark) then
ST.Pop(T.mark, Num);
else
raise Scanner_Not_Marked;
end if;
end Unmark;
----------------------------------------------------------------
procedure Restore(
T : in Scanner
) is
begin
if Is_Valid(T) and then not ST.Is_Empty(T.mark) then
ST.Pop(T.mark, T.index);
else
raise Scanner_Not_Marked;
end if;
end Restore;
----------------------------------------------------------------
function Is_Any(
T : in Scanner;
Q : in STRING
) return BOOLEAN is
N : NATURAL;
begin
if not More(T) then
return FALSE;
end if;
SP.Mark;
N := SP.Match_Any(T.text, Q, T.index);
if N /= T.index then
N := 0;
end if;
SP.Release;
return N /= 0;
end Is_Any;
----------------------------------------------------------------
procedure Scan_Any(
T : in Scanner;
Q : in STRING;
Found : out BOOLEAN;
Result : in out SP.String_Type
) is
S_Str : SP.String_Type;
N : NATURAL;
begin
if Is_Any(T, Q) then
N := SP.Match_None(T.text, Q, T.index);
if N = 0 then
N := SP.Length(T.text) + 1;
end if;
Result := SP."&"(Result, SP.Substr(T.text, T.index, N - T.index));
T.index := N;
Found := TRUE;
else
Found := FALSE;
end if;
end Scan_Any;
----------------------------------------------------------------
function Quoted_String(
T : in Scanner
) return INTEGER is
Count : INTEGER := 0;
I : POSITIVE;
N : NATURAL;
begin
if not More(T) then
return Count;
end if;
I := T.index;
while Is_Any(T, """") loop
T.index := T.index + 1;
if not More(T) then
T.index := I;
return 0;
end if;
SP.Mark;
N := SP.Match_Any(T.text, """", T.index);
SP.Release;
if N = 0 then
T.index := I;
return 0;
end if;
T.index := N + 1;
end loop;
Count := T.index - I;
T.index := I;
return Count;
end Quoted_String;
----------------------------------------------------------------
function Enclosed_String(
B : in CHARACTER;
E : in CHARACTER;
T : in Scanner
) return NATURAL is
Count : NATURAL := 1;
I : POSITIVE;
Inx_B : NATURAL;
Inx_E : NATURAL;
Depth : NATURAL := 1;
begin
if not Is_Any(T, B & "") then
return 0;
end if;
I := T.index;
T.index := T.index + 1;
while Depth /= 0 loop
if not More(T) then
T.index := I;
return 0;
end if;
SP.Mark;
Inx_B := SP.Match_Any(T.text, B & "", T.index);
Inx_E := SP.Match_Any(T.text, E & "", T.index);
SP.Release;
if Inx_E = 0 then
T.index := I;
return 0;
end if;
if Inx_B /= 0 and then Inx_B < Inx_E then
Depth := Depth + 1;
else
Inx_B := Inx_E;
Depth := Depth - 1;
end if;
T.index := Inx_B + 1;
end loop;
Count := T.index - I;
T.index := I;
return Count;
end Enclosed_String;
----------------------------------------------------------------
function Is_Word(
T : in Scanner
) return BOOLEAN is
begin
if not More(T) then
return FALSE;
else
return not Is_Any(T, White_Space);
end if;
end Is_Word;
----------------------------------------------------------------
function Is_Number(
T : in Scanner
) return BOOLEAN is
begin
return Is_Any(T, Number);
end Is_Number;
----------------------------------------------------------------
function Get_Number(
T : in Scanner
) return STRING is
C : CHARACTER;
F : BOOLEAN;
S_Str : SP.String_Type;
begin
SP.Mark;
while Is_Number(T) loop
Scan_Any(T, Number, F, S_Str);
if More(T) then
C := Get(T);
if C = '_' then
T.index := T.index + 1;
if Is_Number(T) then
S_Str := SP."&"(S_Str, "_");
else
T.index := T.index - 1;
end if;
end if;
end if;
end loop;
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
return S;
end;
end Get_Number;
----------------------------------------------------------------
procedure Scan_Number(
T : in Scanner;
Found : out BOOLEAN;
Result : out INTEGER;
Skip : in BOOLEAN := FALSE
) is
begin
if Skip then
Skip_Space(T);
end if;
if Is_Number(T) then
begin
Mark(T);
Result := INTEGER'Value(Get_Number(T));
Unmark(T);
exception
when CONSTRAINT_ERROR =>
Restore(T);
raise Number_Too_Large;
end;
Found := TRUE;
else
Found := FALSE;
end if;
end Scan_Number;
----------------------------------------------------------------
function Is_Signed_Number(
T : in Scanner
) return BOOLEAN is
I : POSITIVE;
C : CHARACTER;
F : BOOLEAN;
begin
if not More(T) then
return FALSE;
end if;
I := T.index;
C := Get(T);
if C = '+' or C = '-' then
T.index := T.index + 1;
end if;
F := Is_Any(T, Number);
T.index := I;
return F;
end Is_Signed_Number;
----------------------------------------------------------------
function Get_Signed_Number(
T : in Scanner
) return STRING is
C : CHARACTER;
begin
C := Get(T);
if C = '+' or C = '-' then
T.index := T.index + 1;
return C & Get_Number(T);
else
return Get_Number(T);
end if;
end Get_Signed_Number;
----------------------------------------------------------------
procedure Scan_Signed_Number(
T : in Scanner;
Found : out BOOLEAN;
Result : out INTEGER;
Skip : in BOOLEAN := FALSE
) is
begin
if Skip then
Skip_Space(T);
end if;
if Is_Signed_Number(T) then
begin
Mark(T);
Result := INTEGER'Value(Get_Signed_Number(T));
Unmark(T);
exception
when CONSTRAINT_ERROR =>
Restore(T);
raise Number_Too_Large;
end;
Found := TRUE;
else
Found := FALSE;
end if;
end Scan_Signed_Number;
----------------------------------------------------------------
function Is_Space(
T : in Scanner
) return BOOLEAN is
begin
return Is_Any(T, White_Space);
end Is_Space;
----------------------------------------------------------------
procedure Skip_Space(
T : in Scanner
) is
S_Str : SP.String_Type;
Found : BOOLEAN;
begin
SP.Mark;
Scan_Any(T, White_Space, Found, S_Str);
SP.Release;
end Skip_Space;
----------------------------------------------------------------
function Is_Ada_Id(
T : in Scanner
) return BOOLEAN is
begin
return Is_Any(T, Alphabetic);
end Is_Ada_Id;
----------------------------------------------------------------
function Is_Quoted(
T : in Scanner
) return BOOLEAN is
begin
if Quoted_String(T) = 0 then
return FALSE;
else
return TRUE;
end if;
end Is_Quoted;
----------------------------------------------------------------
function Is_Enclosed(
B : in CHARACTER;
E : in CHARACTER;
T : in Scanner
) return BOOLEAN is
begin
if Enclosed_String(B, E, T) = 0 then
return FALSE;
else
return TRUE;
end if;
end Is_Enclosed;
----------------------------------------------------------------
function Is_Sequence(
Chars : in STRING;
T : in Scanner
) return BOOLEAN is
begin
return Is_Any(T, Chars);
end Is_Sequence;
----------------------------------------------------------------
function Is_Not_Sequence(
Chars : in STRING;
T : in Scanner
) return BOOLEAN is
N : NATURAL;
begin
if not More(T) then
return FALSE;
end if;
SP.Mark;
N := SP.Match_Any(T.text, Chars, T.index);
if N = T.index then
N := 0;
end if;
SP.Release;
return N /= 0;
end Is_Not_Sequence;
----------------------------------------------------------------
function Is_Literal(
Chars : in STRING;
T : in Scanner
) return BOOLEAN is
N : NATURAL;
begin
if not More(T) then
return FALSE;
end if;
N := SP.Match_S(T.text, Chars, T.index);
if N /= T.index then
N := 0;
end if;
return N /= 0;
end Is_Literal;
----------------------------------------------------------------
function Is_Not_Literal(
Chars : in STRING;
T : in Scanner
) return BOOLEAN is
N : NATURAL;
begin
if not More(T) then
return FALSE;
end if;
SP.Mark;
N := SP.Match_S(T.text, Chars, T.index);
if N = T.index then
N := 0;
end if;
SP.Release;
return N /= 0;
end Is_Not_Literal;
----------------------------------------------------------------
function Match_Character(
T : in CHARACTER;
Char : in STRING
) return BOOLEAN is
begin
for j in Char'range loop
if T = Char(j) then
return TRUE;
end if;
end loop;
return FALSE;
end Match_Character;
----------------------------------------------------------------
function Strip_Leading(
Text : in STRING;
Char : in STRING := " " & ASCII.HT
) return STRING is
begin
for i in Text'range loop
if not Match_Character(Text(i), Char) then
return Text(i .. Text'last);
end if;
end loop;
return "";
end Strip_Leading;
----------------------------------------------------------------
function Strip_Trailing(
Text : in STRING;
Char : in STRING := " " & ASCII.HT
) return STRING is
begin
for i in reverse Text'range loop
if not Match_Character(Text(i), Char) then
return Text(Text'first .. i);
end if;
end loop;
return "";
end Strip_Trailing;
----------------------------------------------------------------
function Strip(
Text : in STRING;
Char : in STRING := " " & ASCII.HT
) return STRING is
begin
return Strip_Leading(STRING'(Strip_Trailing(Text, Char)), Char);
end Strip;
----------------------------------------------------------------
function Justify_String(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER;
Mode : in Justification_Mode
) return STRING is
Out_String : STRING (1 .. Len) := (others => Char);
Temp_String : SP.String_Type;
Index : INTEGER;
begin
SP.Mark;
Temp_String := SP.Create(Out_String & Text & Out_String);
case Mode is
when LEFT =>
Index := Len + 1;
when RIGHT =>
Index := SP.Length(Temp_String) - Len*2 + 1;
when CENTER =>
Index := (SP.Length(Temp_String) - Len)/2 + 2;
when others =>
Index := Len + 1;
end case;
Out_String := SP.Value(SP.Substr(Temp_String, Index, Len));
SP.Release;
return Out_String;
end Justify_String;
----------------------------------------------------------------
function Left_Justify(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return STRING is
begin
return Justify_String(Text, Len, Char, LEFT);
end Left_Justify;
----------------------------------------------------------------
function Right_Justify(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return STRING is
begin
return Justify_String(Text, Len, Char, RIGHT);
end Right_Justify;
----------------------------------------------------------------
function Center(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return STRING is
begin
return Justify_String(Text, Len, Char, CENTER);
end Center;
----------------------------------------------------------------
function Expand(
Text : in STRING;
Len : in POSITIVE
) return STRING is
Out_String : STRING (1 .. Len);
Count : INTEGER := 0;
Size : INTEGER;
Inx1, Inx2 : INTEGER;
S_Str : SP.String_Type;
begin
if Len <= Text'length then
return Justify_String(Text, Len, ' ', LEFT);
end if;
for i in Text'range loop
if Text(i) = ' ' then
Count := Count + 1;
end if;
end loop;
if Count = 0 then
return Justify_String(Text, Len, ' ', LEFT);
end if;
SP.Mark;
S_Str := SP.Create(Text);
Size := (Len - Text'length)/ Count;
Inx1 := Count/2 - ((Len - Text'length) rem Count)/2 + 1;
Inx2 := Inx1 + ((Len - Text'length) rem Count) - 1;
declare
Fill : STRING(1 .. Size) := (others => ' ');
begin
for i in reverse 1 .. SP.Length(S_Str) loop
if SP.Fetch(S_Str, i) = ' ' then
S_Str := SP.Insert(S_Str, Fill, i);
if Inx1 <= Count and Count <= Inx2 then
S_Str := SP.Insert(S_Str, " ", i);
end if;
Count := Count - 1;
end if;
end loop;
end;
Out_String := SP.Value(S_Str);
SP.Release;
return Out_String;
end Expand;
----------------------------------------------------------------
function Format(
Text : in STRING;
Len : in POSITIVE;
Del : in CHARACTER := ' ';
Justify : in Justification_Mode := NONE
) return SL.List is
Out_String : STRING(1 .. Len);
Temp_String : SP.String_Type;
S_Str : SP.String_Type;
Out_List : SL.List := SL.Create;
Index1 : INTEGER;
Index2 : INTEGER;
begin
SP.Mark;
Temp_String := SP.Create(Text);
while SP.Length(Temp_String) > 0 loop
if SP.Length(Temp_String) > Len then
Index1 := Len;
Index2 := Index1;
if Del /= ASCII.NUL then
for i in reverse 2 .. Index1 + 1 loop
if SP.Fetch(Temp_String, i) = Del then
Index1 := i - 1;
Index2 := i;
exit;
end if;
end loop;
end if;
else
Index1 := SP.Length(Temp_String);
Index2 := Index1;
end if;
S_Str := SP.Substr(Temp_String, 1, Index1);
Temp_String := SP.Substr(Temp_String, Index2 + 1, SP.Length(Temp_String) - Index2);
case Justify is
when LEFT | NONE =>
SL.Attach(Out_List, SP.Make_Persistent(
STRING'(Justify_String(SP.Value(S_Str), Len, ' ', LEFT))));
when RIGHT =>
SL.Attach(Out_List, SP.Make_Persistent(
STRING'(Justify_String(SP.Value(S_Str), Len, ' ', RIGHT))));
when CENTER =>
SL.Attach(Out_List, SP.Make_Persistent(
STRING'(Justify_String(SP.Value(S_Str), Len, ' ', CENTER))));
when EXPAND =>
if SP.Length(Temp_String) > 0 then
SL.Attach(Out_List, SP.Make_Persistent(
STRING'(Expand(SP.Value(S_Str), Len))));
else
SL.Attach(Out_List, SP.Make_Persistent(
STRING'(Justify_String(SP.Value(S_Str), Len, ' ', LEFT))));
end if;
end case;
end loop;
SP.Release;
return Out_List;
end Format;
----------------------------------------------------------------
function Image(
Num : in INTEGER;
Len : in NATURAL := 0;
Fill : in CHARACTER := ' '
) return STRING is
S_Str : SP.String_Type;
Places : INTEGER := Len;
Size : INTEGER;
begin
SP.Mark;
S_Str := SP.Create(INTEGER'image(Num));
if SP.Fetch(S_Str, 1) = ' ' then
S_Str := SP.Substr(S_Str, 2, SP.Length(S_Str) - 1);
end if;
Size := SP.Length(S_Str);
if Len = 0 then
Places := Size;
end if;
declare
Temp_Text : STRING (1 .. Places);
begin
for i in 1 .. Places - Size loop
Temp_Text(i) := Fill;
end loop;
Temp_Text(Places - Size + 1 .. Temp_Text'last) := SP.Value(S_Str);
SP.Release;
return Temp_Text;
end;
return "";
end Image;
----------------------------------------------------------------
function Value(
Text : in STRING
) return INTEGER is
Found : BOOLEAN;
Underscore : BOOLEAN := TRUE;
begin
return INTEGER'Value(Text);
exception
when CONSTRAINT_ERROR =>
for i in Text'range loop
Found := FALSE;
for j in Number'range loop
if Text(i) = Number(j) then
Underscore := FALSE;
Found := TRUE;
exit;
end if;
end loop;
if not Found then
if Text(i) /= '_' then
raise Non_Numeric_String;
elsif Underscore then
raise Non_Numeric_String;
else
Underscore := TRUE;
end if;
end if;
end loop;
raise Number_Too_Large;
end Value;
----------------------------------------------------------------
function Match(
Pattern : in STRING;
Target : in STRING;
Wildcard : in CHARACTER := '*';
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
) return BOOLEAN is
type State_Type is (NONE, TEXT, WILD);
List : SL.List := SL.Create;
Iterator : SL.ListIter;
Inx : INTEGER;
R_Str : SP.String_Type;
S_Str : SP.String_Type;
Found : BOOLEAN;
Previous : State_Type;
Current : State_Type;
Old_Opt : SP.Comparison_Option;
begin
Inx := Pattern'first;
SP.Mark;
for i in Pattern'range loop
if Pattern(i) = Wildcard then
if i > Inx then
SL.Attach(List, SP.Create(Pattern(Inx .. i - 1)));
end if;
SL.Attach(List, SP.Create("" & Wildcard));
Inx := i + 1;
end if;
end loop;
if Inx <= Pattern'last then
SL.Attach(List, SP.Create(Pattern(Inx .. Pattern'last)));
end if;
Iterator := SL.MakeListIter(List);
Found := SL.More(Iterator);
Current := NONE;
Inx := Target'first;
Old_Opt := SP.Get_Comparison_Option;
SP.Set_Comparison_Option(Comparison);
while SL.More(Iterator) loop
SL.Next(Iterator, S_Str);
Previous := Current;
if SP.Equal(S_Str, "" & Wildcard) then
Current := WILD;
else
Current := TEXT;
end if;
if Current = TEXT then
Found := FALSE;
SP.Mark;
if Previous = NONE and then
Target'length >= Inx + SP.Length(S_Str) - 1 and then
SP.Equal(S_Str, SP.Create(Target(Inx .. Inx + SP.Length(S_Str) - 1))) then
Inx := Inx + SP.Length(S_Str);
Found := TRUE;
elsif Previous = WILD then
for i in Inx .. Target'last - SP.Length(S_Str) + 1 loop
SP.Mark;
if SP.Equal(S_Str, SP.Create(Target(i .. i + SP.Length(S_Str) - 1))) then
Inx := i + SP.Length(S_Str);
Found := TRUE;
end if;
SP.Release;
end loop;
end if;
SP.Release;
end if;
exit when not Found;
end loop;
if Current = TEXT then
Found := Inx >= Target'length;
end if;
SP.Release;
SL.Destroy(List);
SP.Set_Comparison_Option(Old_Opt);
return Found;
end Match;
----------------------------------------------------------------
pragma page;
package body Generic_String_Utilities is
----------------------------------------------------------------
function Make_Scanner(
S : in Generic_String_Type
) return Scanner is
begin
return Make_Scanner(From_Generic(S));
end Make_Scanner;
----------------------------------------------------------------
function Get_String(
T : in Scanner
) return Generic_String_Type is
begin
if Is_Valid(T) then
return To_Generic(SP.Value(T.text));
else
return To_Generic("");
end if;
end Get_String;
----------------------------------------------------------------
function Get_Remainder(
T : in Scanner
) return Generic_String_Type is
S_Str : SP.String_Type;
G_Str : Generic_String_Type;
begin
if More(T) then
SP.Mark;
S_Str := SP.Substr(T.text, T.index, SP.Length(T.text) - T.index + 1);
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
return To_Generic(S);
end;
else
return To_Generic("");
end if;
end Get_Remainder;
----------------------------------------------------------------
function Get_Segment(
T : in Scanner;
From : in POSITIVE;
To : in POSITIVE
) return Generic_String_Type is
begin
if Is_Valid(T) and then
From < To and then
To <= SP.Length(T.text) then
return To_Generic(SP.Value(T.text)(From .. To - 1));
else
return To_Generic("");
end if;
end Get_Segment;
----------------------------------------------------------------
procedure Scan_Word(
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
S_Str : SP.String_Type;
N : NATURAL;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Word(T) then
Found := TRUE;
SP.Mark;
N := SP.Match_Any(T.text, White_Space, T.index);
if N = 0 then
N := SP.Length(T.text) + 1;
end if;
S_Str := SP.Substr(T.text, T.index, N - T.index);
T.index := N;
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Found := FALSE;
end if;
end Scan_Word;
----------------------------------------------------------------
procedure Scan_Number(
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
begin
if Skip then
Skip_Space(T);
end if;
if Is_Number(T) then
Found := TRUE;
Result := To_Generic(Get_Number(T));
else
Found := FALSE;
end if;
end Scan_Number;
----------------------------------------------------------------
procedure Scan_Signed_Number(
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
begin
if Skip then
Skip_Space(T);
end if;
if Is_Signed_Number(T) then
Found := TRUE;
Result := To_Generic(Get_Signed_Number(T));
else
Found := FALSE;
end if;
end Scan_Signed_Number;
----------------------------------------------------------------
procedure Scan_Space(
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type
) is
S_Str : SP.String_Type;
begin
if Is_Any(T, White_Space) then
SP.Mark;
Scan_Any(T, White_Space, Found, S_Str);
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Found := FALSE;
end if;
end Scan_Space;
----------------------------------------------------------------
procedure Scan_Ada_Id(
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
S_Str : SP.String_Type;
Num : NATURAL;
Mark : POSITIVE;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Ada_Id(T) then
SP.Mark;
Mark := T.index;
Scan_Any(T, Alphabetic & Number & '_', Found, S_Str);
Num := SP.Match_S(S_Str, "__");
if Num /= 0 then
S_Str := SP.Substr(S_Str, 1, Num -1);
Mark := Mark + Num - 1;
else
Num := SP.Length(S_Str);
if SP.Fetch(S_Str, Num) = '_' then
S_Str := SP.Substr(S_Str, 1, Num - 1);
Mark := Mark + Num - 1;
else
Mark := Mark + Num;
end if;
end if;
T.index := Mark;
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Found := FALSE;
end if;
end Scan_Ada_Id;
----------------------------------------------------------------
procedure Scan_Quoted(
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
S_Str : SP.String_Type;
Count : INTEGER;
begin
if Skip then
Skip_Space(T);
end if;
Count := Quoted_String(T);
if Count /= 0 then
Found := TRUE;
Count := Count - 2;
T.index := T.index + 1;
if Count /= 0 then
SP.Mark;
S_Str := SP.Substr(T.text, T.index, POSITIVE(Count));
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Result := To_Generic("");
end if;
T.index := T.index + Count + 1;
else
Found := FALSE;
end if;
end Scan_Quoted;
----------------------------------------------------------------
procedure Scan_Enclosed(
B : in CHARACTER;
E : in CHARACTER;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
S_Str : SP.String_Type;
Count : NATURAL;
begin
if Skip then
Skip_Space(T);
end if;
Count := Enclosed_String(B, E, T);
if Count /= 0 then
Found := TRUE;
Count := Count - 2;
T.index := T.index + 1;
if Count /= 0 then
SP.Mark;
S_Str := SP.Substr(T.text, T.index, POSITIVE(Count));
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Result := To_Generic("");
end if;
T.index := T.index + Count + 1;
else
Found := FALSE;
end if;
end Scan_Enclosed;
----------------------------------------------------------------
function Is_Sequence(
Chars : in Generic_String_Type;
T : in Scanner
) return BOOLEAN is
begin
return Is_Any(T, From_Generic(Chars));
end Is_Sequence;
----------------------------------------------------------------
procedure Scan_Sequence(
Chars : in Generic_String_Type;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
begin
Scan_Sequence(From_Generic(Chars), T, Found, Result, Skip);
end Scan_Sequence;
----------------------------------------------------------------
procedure Scan_Sequence(
Chars : in STRING;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
I : POSITIVE;
Count : INTEGER := 0;
S_Str : SP.String_Type;
begin
if Skip then
Skip_Space(T);
end if;
if not Is_Valid(T) then
Found := FALSE;
return;
end if;
I := T.index;
while Is_Any(T, Chars) loop
T.index := T.index + 1;
Count := Count + 1;
end loop;
if Count /= 0 then
Found := TRUE;
SP.Mark;
S_Str := SP.Substr(T.text, I, POSITIVE(Count));
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Found := FALSE;
end if;
end Scan_Sequence;
----------------------------------------------------------------
function Is_Not_Sequence(
Chars : in Generic_String_Type;
T : in Scanner
) return BOOLEAN is
begin
return Is_Not_Sequence(From_Generic(Chars), T);
end Is_Not_Sequence;
----------------------------------------------------------------
procedure Scan_Not_Sequence(
Chars : in STRING;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
S_Str : SP.String_Type;
N : NATURAL;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Not_Sequence(Chars, T) then
Found := TRUE;
SP.Mark;
N := SP.Match_Any(T.text, Chars, T.index);
S_Str := SP.Substr(T.text, T.index, N - T.index);
T.index := N;
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Found := FALSE;
end if;
end Scan_Not_Sequence;
----------------------------------------------------------------
procedure Scan_Not_Sequence(
Chars : in Generic_String_Type;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
begin
Scan_Not_Sequence(From_Generic(Chars), T, Found, Result, Skip);
end Scan_Not_Sequence;
----------------------------------------------------------------
function Is_Literal(
Chars : in Generic_String_Type;
T : in Scanner
) return BOOLEAN is
begin
return Is_Literal(From_Generic(Chars), T);
end Is_Literal;
----------------------------------------------------------------
procedure Scan_Literal(
Chars : in STRING;
T : in Scanner;
Found : out BOOLEAN;
Skip : in BOOLEAN := FALSE
) is
begin
if Skip then
Skip_Space(T);
end if;
if Is_Literal(Chars, T) then
T.index := T.index + Chars'length;
Found := TRUE;
else
Found := FALSE;
end if;
end Scan_Literal;
----------------------------------------------------------------
procedure Scan_Literal(
Chars : in Generic_String_Type;
T : in Scanner;
Found : out BOOLEAN;
Skip : in BOOLEAN := FALSE
) is
F : BOOLEAN;
begin
Scan_Literal(From_Generic(Chars), T, Found, Skip);
end Scan_Literal;
----------------------------------------------------------------
function Is_Not_Literal(
Chars : in Generic_String_Type;
T : in Scanner
) return BOOLEAN is
begin
return Is_Not_Literal(From_Generic(Chars), T);
end Is_Not_Literal;
----------------------------------------------------------------
procedure Scan_Not_Literal(
Chars : in STRING;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
S_Str : SP.String_Type;
N : NATURAL;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Not_Literal(Chars, T) then
Found := TRUE;
SP.Mark;
N := SP.Match_S(T.text, Chars, T.index);
S_Str := SP.Substr(T.text, T.index, N - T.index);
T.index := N;
declare
S : STRING (1 .. SP.Length(S_Str));
begin
S := SP.Value(S_Str);
SP.Release;
Result := To_Generic(S);
end;
else
Found := FALSE;
end if;
end Scan_Not_Literal;
----------------------------------------------------------------
procedure Scan_Not_Literal(
Chars : in Generic_String_Type;
T : in Scanner;
Found : out BOOLEAN;
Result : out Generic_String_Type;
Skip : in BOOLEAN := FALSE
) is
begin
Scan_Not_Literal(From_Generic(Chars), T, Found, Result, Skip);
end Scan_Not_Literal;
----------------------------------------------------------------
function Strip_Leading(
Text : in Generic_String_Type;
Char : in STRING := " " & ASCII.HT
) return STRING is
begin
return Strip_Leading(From_Generic(Text), Char);
end Strip_Leading;
----------------------------------------------------------------
function Strip_Leading(
Text : in STRING;
Char : in STRING := " " & ASCII.HT
) return Generic_String_Type is
begin
return To_Generic(STRING'(Strip_Leading(Text, Char)));
end Strip_Leading;
----------------------------------------------------------------
function Strip_Leading(
Text : in Generic_String_Type;
Char : in STRING := " " & ASCII.HT
) return Generic_String_Type is
G_Str : Generic_String_Type;
begin
return To_Generic(STRING'(Strip_Leading(From_Generic(Text), Char)));
end Strip_Leading;
----------------------------------------------------------------
function Strip_Trailing(
Text : in Generic_String_Type;
Char : in STRING := " " & ASCII.HT
) return STRING is
begin
return Strip_Trailing(From_Generic(Text), Char);
end Strip_Trailing;
----------------------------------------------------------------
function Strip_Trailing(
Text : in STRING;
Char : in STRING := " " & ASCII.HT
) return Generic_String_Type is
begin
return To_Generic(STRING'(Strip_Trailing(Text, Char)));
end Strip_Trailing;
----------------------------------------------------------------
function Strip_Trailing(
Text : in Generic_String_Type;
Char : in STRING := " " & ASCII.HT
) return Generic_String_Type is
begin
return To_Generic(STRING'(Strip_Trailing(From_Generic(Text), Char)));
end Strip_Trailing;
----------------------------------------------------------------
function Strip(
Text : in Generic_String_Type;
Char : in STRING := " " & ASCII.HT
) return STRING is
begin
return Strip_Leading(STRING'(Strip_Trailing(From_Generic(Text), Char)), Char);
end Strip;
----------------------------------------------------------------
function Strip(
Text : in STRING;
Char : in STRING := " " & ASCII.HT
) return Generic_String_Type is
begin
return To_Generic(STRING'(Strip_Leading(STRING'(Strip_Trailing(Text, Char)), Char)));
end Strip;
----------------------------------------------------------------
function Strip(
Text : in Generic_String_Type;
Char : in STRING := " " & ASCII.HT
) return Generic_String_Type is
begin
return To_Generic(STRING'(Strip_Leading(STRING'(Strip_Trailing(From_Generic(Text), Char)), Char)));
end Strip;
----------------------------------------------------------------
function Left_Justify(
Text : in Generic_String_Type;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return STRING is
begin
return Justify_String(From_Generic(Text), Len, Char, LEFT);
end Left_Justify;
----------------------------------------------------------------
function Left_Justify(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(Justify_String(Text, Len, Char, LEFT));
end Left_Justify;
----------------------------------------------------------------
function Left_Justify(
Text : in Generic_String_Type;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(Justify_String(From_Generic(Text), Len, Char, LEFT));
end Left_Justify;
----------------------------------------------------------------
function Right_Justify(
Text : in Generic_String_Type;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return STRING is
begin
return Justify_String(From_Generic(Text), Len, Char, RIGHT);
end Right_Justify;
----------------------------------------------------------------
function Right_Justify(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(Justify_String(Text, Len, Char, RIGHT));
end Right_Justify;
----------------------------------------------------------------
function Right_Justify(
Text : in Generic_String_Type;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(Justify_String(From_Generic(Text), Len, Char, RIGHT));
end Right_Justify;
----------------------------------------------------------------
function Center(
Text : in Generic_String_Type;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return STRING is
begin
return Justify_String(From_Generic(Text), Len, Char, CENTER);
end Center;
----------------------------------------------------------------
function Center(
Text : in STRING;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(Justify_String(Text, Len, Char, CENTER));
end Center;
----------------------------------------------------------------
function Center(
Text : in Generic_String_Type;
Len : in POSITIVE;
Char : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(Justify_String(From_Generic(Text), Len, Char, CENTER));
end Center;
----------------------------------------------------------------
function Expand(
Text : in Generic_String_Type;
Len : in POSITIVE
) return STRING is
begin
return Expand(From_Generic(Text), Len);
end Expand;
----------------------------------------------------------------
function Expand(
Text : in STRING;
Len : in POSITIVE
) return Generic_String_Type is
begin
return To_Generic(Expand(Text, Len));
end Expand;
----------------------------------------------------------------
function Expand(
Text : in Generic_String_Type;
Len : in POSITIVE
) return Generic_String_Type is
begin
return To_Generic(Expand(From_Generic(Text), Len));
end Expand;
----------------------------------------------------------------
function Format(
Text : in Generic_String_Type;
Len : in POSITIVE;
Del : in CHARACTER := ' ';
Justify : in Justification_Mode := NONE
) return SL.List is
begin
return Format(From_Generic(Text), Len, Del, Justify);
end Format;
----------------------------------------------------------------
function Image(
Num : in INTEGER;
Len : in NATURAL := 0;
Fill : in CHARACTER := ' '
) return Generic_String_Type is
begin
return To_Generic(STRING'(Image(Num, Len, Fill)));
end Image;
----------------------------------------------------------------
function Value(
Text : in Generic_String_Type
) return INTEGER is
begin
return Value(STRING'(From_Generic(Text)));
end Value;
----------------------------------------------------------------
function Match(
Pattern : in Generic_String_Type;
Target : in STRING;
Wildcard : in CHARACTER := '*';
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
) return BOOLEAN is
begin
return Match(From_Generic(Pattern),
Target,
Wildcard,
Comparison);
end Match;
----------------------------------------------------------------
function Match(
Pattern : in STRING;
Target : in Generic_String_Type;
Wildcard : in CHARACTER := '*';
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
) return BOOLEAN is
begin
return Match(Pattern,
From_Generic(Target),
Wildcard,
Comparison);
end Match;
----------------------------------------------------------------
function Match(
Pattern : in Generic_String_Type;
Target : in Generic_String_Type;
Wildcard : in CHARACTER := '*';
Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
) return BOOLEAN is
begin
return Match(From_Generic(Pattern),
From_Generic(Target),
Wildcard,
Comparison);
end Match;
----------------------------------------------------------------
end Generic_String_Utilities;
end String_Utilities;
pragma page;
--::::::::::
--stack.spc
--::::::::::
-- $Source: /nosc/work/abstractions/stack/RCS/stack.spc,v $
-- $Revision: 1.5 $ -- $Date: 85/02/01 09:57:17 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/stack/RCS/stack.spc,v $
-- $Revision: 1.5 $ -- $Date: 85/02/01 09:57:17 $ -- $Author: ron $
with lists; --| Implementation uses lists. (private)
generic
type elem_type is private; --| Component element type.
package stack_pkg is
--| Overview:
--| This package provides the stack abstract data type. Element type is
--| a generic formal parameter to the package. There are no explicit
--| bounds on the number of objects that can be pushed onto a given stack.
--| All standard stack operations are provided.
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec. Overloaded subprograms are followed
--| by (n), where n is the number of subprograms of that name.
--|
--| Constructors:
--| create
--| push
--| pop (2)
--| copy
--| Query Operations:
--| top
--| size
--| is_empty
--| Heap Management:
--| destroy
--| Notes:
--| Programmer: Ron Kownacki
type stack is private; --| The stack abstract data type.
-- Exceptions:
uninitialized_stack: exception;
--| Raised on attempt to manipulate an uninitialized stack object.
--| The initialization operations are create and copy.
empty_stack: exception;
--| Raised by some operations when empty.
-- Constructors:
function create
return stack;
--| Effects:
--| Return the empty stack.
procedure push(s: in out stack;
e: elem_type);
--| Raises: uninitialized_stack
--| Effects:
--| Push e onto the top of s.
--| Raises uninitialized_stack iff s has not been initialized.
procedure pop(s: in out stack);
--| Raises: empty_stack, uninitialized_stack
--| Effects:
--| Pops the top element from s, and throws it away.
--| Raises empty_stack iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
procedure pop(s: in out stack;
e: out elem_type);
--| Raises: empty_stack, uninitialized_stack
--| Effects:
--| Pops the top element from s, returns it as the e parameter.
--| Raises empty_stack iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
function copy(s: stack)
return stack;
--| Raises: uninitialized_stack
--| Return a copy of s.
--| Stack assignment and passing stacks as subprogram parameters
--| result in the sharing of a single stack value by two stack
--| objects; changes to one will be visible through the others.
--| copy can be used to prevent this sharing.
--| Raises uninitialized_stack iff s has not been initialized.
-- Queries:
function top(s: stack)
return elem_type;
--| Raises: empty_stack, uninitialized_stack
--| Effects:
--| Return the element on the top of s. Raises empty_stack iff s is
--| empty.
--| Raises uninitialized_stack iff s has not been initialized.
function size(s: stack)
return natural;
--| Raises: uninitialized_stack
--| Effects:
--| Return the current number of elements in s.
--| Raises uninitialized_stack iff s has not been initialized.
function is_empty(s: stack)
return boolean;
--| Raises: uninitialized_stack
--| Effects:
--| Return true iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
-- Heap Management:
procedure destroy(s: in out stack);
--| Effects:
--| Return the space consumed by s to the heap. No effect if s is
--| uninitialized. In any case, leaves s in uninitialized state.
private
package elem_list_pkg is new lists(elem_type);
subtype elem_list is elem_list_pkg.list;
type stack_rec is
record
size: natural := 0;
elts: elem_list := elem_list_pkg.create;
end record;
type stack is access stack_rec;
--| Let an instance of the representation type, r, be denoted by the
--| pair, . Dot selection is used to refer to these
--| components.
--|
--| Representation Invariants:
--| r /= null
--| elem_list_pkg.length(r.elts) = r.size.
--|
--| Abstraction Function:
--| A() = stack_pkg.create.
--| A() = push(A(), e).
end stack_pkg;
--::::::::::
--stack.bdy
--::::::::::
-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $
with unchecked_deallocation;
package body stack_pkg is
--| Overview:
--| Implementation scheme is totally described by the statements of the
--| representation invariants and abstraction function that appears in
--| the package specification. The implementation is so trivial that
--| further documentation is unnecessary.
use elem_list_pkg;
-- Constructors:
function create
return stack is
begin
return new stack_rec'(size => 0, elts => create);
end create;
procedure push(s: in out stack;
e: elem_type) is
begin
s.size := s.size + 1;
s.elts := attach(e, s.elts);
exception
when constraint_error =>
raise uninitialized_stack;
end push;
procedure pop(s: in out stack) is
begin
DeleteHead(s.elts);
s.size := s.size - 1;
exception
when EmptyList =>
raise empty_stack;
when constraint_error =>
raise uninitialized_stack;
end pop;
procedure pop(s: in out stack;
e: out elem_type) is
begin
e := FirstValue(s.elts);
DeleteHead(s.elts);
s.size := s.size - 1;
exception
when EmptyList =>
raise empty_stack;
when constraint_error =>
raise uninitialized_stack;
end pop;
function copy(s: stack)
return stack is
begin
if s = null then raise uninitialized_stack; end if;
return new stack_rec'(size => s.size,
elts => copy(s.elts));
end;
-- Queries:
function top(s: stack)
return elem_type is
begin
return FirstValue(s.elts);
exception
when EmptyList =>
raise empty_stack;
when constraint_error =>
raise uninitialized_stack;
end top;
function size(s: stack)
return natural is
begin
return s.size;
exception
when constraint_error =>
raise uninitialized_stack;
end size;
function is_empty(s: stack)
return boolean is
begin
return s.size = 0;
exception
when constraint_error =>
raise uninitialized_stack;
end is_empty;
-- Heap Management:
procedure destroy(s: in out stack) is
procedure free_stack is
new unchecked_deallocation(stack_rec, stack);
begin
destroy(s.elts);
free_stack(s);
exception
when constraint_error => -- stack is null
return;
end destroy;
end stack_pkg;
--::::::::::
--cisc.spc
--::::::::::
package case_insensitive_string_comparison is
--| Overview
--| This package provides a complete set of comparison functions on strings
--| where case is NOT important ("a" = "A").
--| Standard_Renaming: CISC or simply SC
--| Programmer: M. Gordon
------------------------------------------------------------------------
function toUpper( --| Return upper case equivalent of C.
C: character
) return character;
--| Effects: If C is in 'a'..'z' return the corresponding upper case
--| character. Otherwise, return C. This is implemented by a table
--| lookup for speed.
--| N/A: Raises, Requires, Modifies
procedure upCase( --| Convert all characters in S to upper case
S: in out String
);
--| Effects: Convert all characters in S to upper case.
--| N/A: Raises, Requires, Modifies
pragma inline(upCase);
function upCase( --| Return copy of S with all characters upper case
S: String
) return String;
--| Effects: Make a copy of S, convert all lower case characters to upper
--| case and return the copy.
--| N/A: Raises, Requires, Modifies
------------------------------------------------------------------------
function toLower( --| Return lower case equivalent of C.
C: character
) return character;
--| Effects: If C is in 'A'..'Z' return the corresponding lower case
--| character. Otherwise, return C. This is implemented by a table
--| lookup for speed.
--| N/A: Raises, Requires, Modifies
procedure downCase( --| Convert all characters in S to lower case
S: in out String
);
--| Effects: Convert all characters in S to lower case.
--| N/A: Raises, Requires, Modifies
pragma inline(downCase);
function downCase( --| Return copy of S with all characters lower case
S: String
) return String;
--| Effects: Make a copy of S, convert all lower case characters to lower
--| case and return the copy.
--| N/A: Raises, Requires, Modifies
------------------------------------------------------------------------
function compare( --| Compare two strings
P, Q: String
) return integer;
--| Effects: Return an integer less than zero if P < Q, zero if P = Q, and
--| an integer greater than zero if P > Q.
--| N/A: Raises, Requires, Modifies
------------------------------------------------------------------------
function equal( --| Return True iff P = Q.
P, Q: String
) return boolean;
--| N/A: Raises, Requires, Modifies, Effects
function less( --| Return True iff P < Q.
P, Q: String
) return boolean;
--| N/A: Raises, Requires, Modifies, Effects
function less_or_equal( --| Return True iff P <= Q.
P, Q: String
) return boolean;
--| N/A: Raises, Requires, Modifies, Effects
function greater( --| Return True iff P > Q.
P, Q: String
) return boolean;
--| N/A: Raises, Requires, Modifies, Effects
function greater_or_equal( --| Return True iff P >= Q.
P, Q: String
) return boolean;
--| N/A: Raises, Requires, Modifies, Effects
------------------------------------------------------------------------
private
pragma inline(equal, less, less_or_equal, greater, greater_or_equal);
pragma inline(toUpper, toLower);
end case_insensitive_string_comparison;
--::::::::::
--cisc.bdy
--::::::::::
package body case_insensitive_string_comparison is
--| Overview
--| Strings are compared one character at a time, stopping as soon as
--| possible.
--| Programmer: M. Gordon
------------------------------------------------------------------------
Up_ConvertArray: array(Character) of Character;
Down_ConvertArray: array(Character) of Character;
Difference: constant := Character'pos('a') - Character'pos('A');
function toUpper(C: character) return character is
begin
return Up_ConvertArray(C);
end toUpper;
function upCase( --| Return copy of S with all characters lower case
S: String
) return String
is
R: String(S'Range) := S;
begin
for i in R'Range loop
R(i) := toUpper(R(i));
end loop;
return R;
end upCase;
procedure upCase( --| Convert all characters in S to lower case
S: in out String
) is
begin
for i in S'Range loop
S(i) := toUpper(S(i));
end loop;
end upCase;
------------------------------------------------------------------------
function toLower(C: character) return character is
begin
return Down_ConvertArray(C);
end toLower;
function downCase( --| Return copy of S with all characters lower case
S: String
) return String
is
R: String(S'Range) := S;
begin
for i in R'Range loop
R(i) := toLower(R(i));
end loop;
return R;
end downCase;
procedure downCase( --| Convert all characters in S to lower case
S: in out String
) is
begin
for i in S'Range loop
S(i) := toLower(S(i));
end loop;
end downCase;
------------------------------------------------------------------------
function compare( --| Compare two strings
P, Q: String
) return integer
is
PI, QI: natural;
PC, QC: character;
begin
QI := Q'First;
for PI in P'First .. P'Last loop
if QI > Q'Last then
return 1; -- Q ran out before P did.
end if;
PC := toUpper(P(PI));
QC := toUpper(Q(QI));
if PC /= QC then
return character'pos(PC) - character'pos(QC);
end if;
QI := QI + 1;
end loop;
return P'Length - Q'Length; -- Equal so far: longer string is greater
end compare;
------------------------------------------------------------------------
function equal(
P, Q: String
) return boolean is
begin
return compare(P, Q) = 0;
end equal;
------------------------------------------------------------------------
function less(
P, Q: String
) return boolean is
begin
return compare(P, Q) < 0;
end less;
function less_or_equal(
P, Q: String
) return boolean is
begin
return compare(P, Q) <= 0;
end less_or_equal;
------------------------------------------------------------------------
function greater(
P, Q: String
) return boolean is
begin
return compare(P, Q) > 0;
end greater;
function greater_or_equal(
P, Q: String
) return boolean is
begin
return compare(P, Q) >= 0;
end greater_or_equal;
------------------------------------------------------------------------
begin
for I in Character loop
case I is
when 'a' .. 'z' =>
Up_ConvertArray(I) := Character'val(Character'pos(I) - Difference);
when others =>
Up_ConvertArray(I) := I;
end case;
end loop;
for I in Character loop
case I is
when 'A' .. 'Z' =>
Down_ConvertArray(I) := Character'val(Character'pos(I) + Difference);
when others =>
Down_ConvertArray(I) := I;
end case;
end loop;
end case_insensitive_string_comparison;