|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 87207 (0x154a7)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦8483af073⟧
└─⟦this⟧
-- <!DOCTYPE ADA>
-- <ADA>
--------------------------------------------------------------------------------
-- <PROLOGUE>
-- <UNIT> Character_Utilities
--
-- <DESCRIPTION> This package defines subtypes and operations for working with
-- ASCII characters.
--
-- <HISTORY>
--
-- <ORIGIN>
-- <AUTHOR> David Blanchard and Peter A. Berggren
-- <DATE> 12 July 1989
--
-- <COMPANY> Science Applications International Corporation
-- <ADDRESS> 311 Park Place Boulevard, Suite 360
-- <ADDRESS> Clearwater, Florida 34619
--
-- <REMARK> The specification of this package was derived from "Software
-- Components with Ada", by Grady Booch.
-- Developed for the STARS program under task IR20.
-- </ORIGIN>
--
-- </HISTORY>
--
-- <NOTES> Dependencies =>
-- ( Operating_System => None ,
-- Compiler => None ,
-- Device => None ) ;
--
-- <copyright notice>
-- This component was derived from specifications described in the book,
-- "Software Components with Ada", by Grady Booch.
--
--
-- </PROLOGUE>
--------------------------------------------------------------------------------
package Character_Utilities is
subtype Control_Character is Character range ASCII.Nul .. ASCII.Us ;
subtype Graphic_Character is Character range ' ' .. '~' ;
subtype Uppercase_Character is Character range 'A' .. 'Z' ;
subtype Lowercase_Character is Character range 'a' .. 'z' ;
subtype Digit_Character is Character range '0' .. '9' ;
--
-- These subtypes define the conventional ranges of ASCII character values, as
-- follows:
--
-- Control_Character => The first 32 characters in the ASCII set. These
-- characters generally invoke some kind
-- of control operation, rather than producing a graphic
-- image.
-- Graphic_Character => The 95 characters of the ASCII set that always produce
-- a graphic image.
-- Uppercase_Character => The uppercase alphabetic characters.
-- Lowercase_Character => The lowercase alphabetic characters.
-- Digit_Character => The decimal digits.
--
-- Note: The subtypes Control_Character and Graphic_Character do not
-- cover the complete range of ASCII characters. The last character in the set,
-- (ASCII.DEL) is a control character, but cannot be included in
-- the subtype Control_Character because it is not contiguous with the other
-- control characters.
--
subtype Digit is Integer range 0 .. 9 ;
subtype Letter is Integer range 1 .. 26 ;
--
-- The subtypes Digit and Letter provide Integer mappings for decimal digit and
-- alphabetic characters, respectively.
--
procedure Make_Uppercase ( The_Character : in out Character ) ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Make_Uppercase
--
-- <DESCRIPTION> This procedure maps from the lowercase characters to the
-- uppercase characters.
-- If the character given by The_Character is
-- lowercase, it is changed to the equivalent uppercase character.
-- Otherwise, no action is taken.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
procedure Make_Lowercase ( The_Character : in out Character ) ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Make_Lowercase
--
-- <DESCRIPTION> This procedure maps from the uppercase characters to the
-- lowercase characters.
-- If the character given by The_Character is
-- uppercase, it is changed to the equivalent lowercase character.
-- Otherwise, no action is taken.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Uppercase_Of ( The_Character : in Character ) return Character ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Uppercase_Of
--
-- <DESCRIPTION> This function returns the uppercase equivalent of the character
-- given by The_Character or, if the given
-- character is not alphabetic, returns the character itself.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Lowercase_Of ( The_Character : in Character ) return Character ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Lowercase_Of
--
-- <DESCRIPTION> This function returns the lowercase equivalent of the character
-- given by The_Character or, if the given
-- character is not alphabetic, returns the character itself.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Control ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Control
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is a control character.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Graphic ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Graphic
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is a graphic character.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Uppercase ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Uppercase
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is uppercase.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Lowercase ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Lowercase
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is lowercase.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Digit ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Digit
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is a decimal digit.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Alphabetic ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Alphabetic
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is alphabetic.
-- The set of alphabetic characters is defined as the union of the
-- uppercase and lowercase sets.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Alphanumeric ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Alphanumeric
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is alphanumeric.
-- The set of alphanumeric characters is defined as the union of
-- the alphabetic and decimal digit sets.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Special ( The_Character : in Character ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Special
--
-- <DESCRIPTION> This function returns True if the character given by
-- The_Character is special.
-- The set of special characters includes the graphic characters,
-- less the alphanumeric characters.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Value_Of ( The_Character : in Character ) return Digit ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Value_Of
--
-- <DESCRIPTION> This function returns the integer value of the decimal digit
-- given by The_Character.
--
-- <EXCEPTIONS> Lexical_Error =>
-- The character given by The_Character is not a decimal digit.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Image_Of ( The_Digit : in Digit ) return Character ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Image_Of
--
-- <DESCRIPTION> This function returns the decimal digit corresponding to the
-- integer value given by The_Digit.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Index_Of ( The_Character : in Character ) return Letter ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Index_Of
--
-- <DESCRIPTION> This function returns the position in the alphabet of the
-- character given by The_Character.
-- For example, 'C' and 'c' produce the value 3.
--
-- <EXCEPTIONS> Lexical_Error =>
-- The character given by The_Character is not alphabetic.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Uppercase_Of ( The_Letter : in Letter ) return Character ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Uppercase_Of
--
-- <DESCRIPTION> This function returns the uppercase character whose position in
-- the alphabet is given by The_Letter.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Lowercase_Of ( The_Letter : in Letter ) return Character ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Lowercase_Of
--
-- <DESCRIPTION> This function returns the lowercase character whose position in
-- the alphabet is given by The_Letter.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Equal
( Left : in Character ;
Right : in Character ;
Case_Sensitive : in Boolean := True ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Equal
--
-- <DESCRIPTION> This function returns True if the characters given by Left and
-- Right are equal.
-- The parameter Case_Sensitive determines the handling of
-- character case, as follows:
-- True => The uppercase and lowercase character sets are treated
-- as distinct sets.
-- False => The lowercase character set is mapped onto the
-- uppercase character set.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Less_Than
( Left : in Character ;
Right : in Character ;
Case_Sensitive : in Boolean := True ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Less_Than
--
-- <DESCRIPTION> This function returns True if the character given by Left is
-- less than the character given by Right.
-- The parameter Case_Sensitive determines the handling of
-- character case, as follows:
-- True => The uppercase and lowercase character sets are treated
-- as distinct sets.
-- False => The lowercase character set is mapped onto the
-- uppercase character set.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
function Is_Greater_Than
( Left : in Character ;
Right : in Character ;
Case_Sensitive : in Boolean := True ) return Boolean ;
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Greater_Than
--
-- <DESCRIPTION> This function returns True if the character given by Left is
-- greater than the character given by Right.
-- The parameter Case_Sensitive determines the handling of
-- character case, as follows:
-- True => The uppercase and lowercase character sets are treated
-- as distinct sets.
-- False => The lowercase character set is mapped onto the
-- uppercase character set.
--
-- <EXCEPTIONS> None
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
Lexical_Error : exception ;
--
-- The exception Lexical_Error is raised by functions Value_Of
-- and Index_Of, if the given character is not a decimal digit or an alphabetic
-- character, respectively.
--
end Character_Utilities ;
-- </ADA>
-- <!DOCTYPE ADA>
-- <ADA>
--------------------------------------------------------------------------------
-- <PROLOGUE>
-- <UNIT> Character_Utilities
--
-- <DESCRIPTION> This package defines subtypes and operations for working with
-- ASCII characters.
--
-- <HISTORY>
--
-- <ORIGIN>
-- <AUTHOR> David Blanchard and Peter A. Berggren
-- <DATE> 12 July 1989
--
-- <COMPANY> Science Applications International Corporation
-- <ADDRESS> 311 Park Place Boulevard, Suite 360
-- <ADDRESS> Clearwater, Florida 34619
--
-- <REMARK> The specification of this package was derived from "Software
-- Components with Ada", by Grady Booch.
-- Developed for the STARS program under task IR20.
-- </ORIGIN>
--
-- </HISTORY>
--
-- <NOTES> Dependencies =>
-- ( Operating_System => None ,
-- Compiler => None ,
-- Device => None ) ;
--
-- <copyright notice>
-- This component was derived from specifications described in the book,
-- "Software Components with Ada", by Grady Booch.
--
--
-- </PROLOGUE>
--------------------------------------------------------------------------------
package body Character_Utilities is
The_Case_Offset : constant := Character'Pos ( 'a' ) - Character'Pos ( 'A' ) ;
--
-- The constant The_Case_Offset defines the offset from the uppercase character
-- set to the lowercase character set.
--
procedure Make_Uppercase ( The_Character : in out Character ) is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Make_Uppercase
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Make_Uppercase
The_Character := Uppercase_Of ( The_Character => The_Character ) ;
end Make_Uppercase ;
procedure Make_Lowercase ( The_Character : in out Character ) is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Make_Lowercase
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Make_Lowercase
The_Character := Lowercase_Of ( The_Character => The_Character ) ;
end Make_Lowercase ;
function Uppercase_Of ( The_Character : in Character ) return Character is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Uppercase_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Uppercase_Of
if Is_Lowercase ( The_Character => The_Character ) then
return
Character'Val ( Character'Pos ( The_Character ) - The_Case_Offset ) ;
else
return The_Character ;
end if ;
end Uppercase_Of ;
function Lowercase_Of ( The_Character : in Character ) return Character is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Lowercase_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Lowercase_Of
if Is_Uppercase ( The_Character => The_Character ) then
return
Character'Val ( Character'Pos ( The_Character ) + The_Case_Offset ) ;
else
return The_Character ;
end if ;
end Lowercase_Of ;
function Is_Control ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Control
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Control
return The_Character in Control_Character ;
end Is_Control ;
function Is_Graphic ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Graphic
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Graphic
return The_Character in Graphic_Character ;
end Is_Graphic ;
function Is_Uppercase ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Uppercase
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Uppercase
return The_Character in Uppercase_Character ;
end Is_Uppercase ;
function Is_Lowercase ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Lowercase
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Lowercase
return The_Character in Lowercase_Character ;
end Is_Lowercase ;
function Is_Digit ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Digit
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Digit
return The_Character in Digit_Character ;
end Is_Digit ;
function Is_Alphabetic ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Alphabetic
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Alphabetic
return Is_Uppercase ( The_Character => The_Character ) or else
Is_Lowercase ( The_Character => The_Character ) ;
end Is_Alphabetic ;
function Is_Alphanumeric ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Alphanumeric
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Alphanumeric
return Is_Alphabetic ( The_Character => The_Character ) or else
Is_Digit ( The_Character => The_Character ) ;
end Is_Alphanumeric ;
function Is_Special ( The_Character : in Character ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Special
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Special
return Is_Graphic ( The_Character => The_Character ) and then
not Is_Alphanumeric ( The_Character => The_Character ) ;
end Is_Special ;
function Value_Of ( The_Character : in Character ) return Digit is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Value_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Value_Of
if Is_Digit ( The_Character => The_Character ) then
return Character'Pos ( The_Character ) - Character'Pos ( '0' ) ;
else
raise Lexical_Error ;
end if ;
end Value_Of ;
function Image_Of ( The_Digit : in Digit ) return Character is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Image_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Image_Of
return Character'Val ( Character'Pos ( '0' ) + The_Digit ) ;
end Image_Of ;
function Index_Of ( The_Character : in Character ) return Letter is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Index_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Index_Of
if Is_Uppercase ( The_Character => The_Character ) then
return Character'Pos ( The_Character ) - Character'Pos ( 'A' ) + 1 ;
elsif Is_Lowercase ( The_Character => The_Character ) then
return Character'Pos ( The_Character ) - Character'Pos ( 'a' ) + 1 ;
else
raise Lexical_Error ;
end if ;
end Index_Of ;
function Uppercase_Of ( The_Letter : in Letter ) return Character is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Uppercase_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Uppercase_Of
return Character'Val ( Character'Pos ( 'A' ) + The_Letter - 1 ) ;
end Uppercase_Of ;
function Lowercase_Of ( The_Letter : in Letter ) return Character is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Lowercase_Of
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Lowercase_Of
return Character'Val ( Character'Pos ( 'a' ) + The_Letter - 1 ) ;
end Lowercase_Of ;
function Is_Equal
( Left : in Character ;
Right : in Character ;
Case_Sensitive : in Boolean := True ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Equal
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Equal
if Case_Sensitive then
return Left = Right ;
else
return Uppercase_Of ( The_Character => Left ) =
Uppercase_Of ( The_Character => Right ) ;
end if ;
end Is_Equal ;
function Is_Less_Than
( Left : in Character ;
Right : in Character ;
Case_Sensitive : in Boolean := True ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Less_Than
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Less_Than
if Case_Sensitive then
return Left < Right ;
else
return Uppercase_Of ( The_Character => Left ) <
Uppercase_Of ( The_Character => Right ) ;
end if ;
end Is_Less_Than ;
function Is_Greater_Than
( Left : in Character ;
Right : in Character ;
Case_Sensitive : in Boolean := True ) return Boolean is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> Is_Greater_Than
--
-- <DESCRIPTION> For a complete description of this subprogram see the
-- specification of this package.
--
-- <EXCEPTIONS> For a complete description of the exceptions raised by this
-- subprogram see the specification of this package.
--
-- </SUBPROGRAM>
--------------------------------------------------------------------------------
begin -- Is_Greater_Than
if Case_Sensitive then
return Left > Right ;
else
return Uppercase_Of ( The_Character => Left ) >
Uppercase_Of ( The_Character => Right ) ;
end if ;
end Is_Greater_Than ;
end Character_Utilities ;
-- </ADA>
package Bounded_String is
subtype String_Length is Natural;
type Variable_String (Maximum_Length : String_Length) is private;
-- initialized to have a length of 0
procedure Copy (Target : in out Variable_String; Source : Variable_String);
procedure Copy (Target : in out Variable_String; Source : String);
procedure Copy (Target : in out Variable_String; Source : Character);
procedure Move (Target : in out Variable_String;
Source : in out Variable_String);
function Image (V : Variable_String) return String;
-- Value function with maximum length = current length
function Value (S : String) return Variable_String;
-- Value function with specified maximum length
function Value (S : String; Max_Length : Natural) return Variable_String;
pragma Inline (Image);
procedure Free (V : in out Variable_String);
procedure Append (Target : in out Variable_String;
Source : Variable_String);
procedure Append (Target : in out Variable_String; Source : String);
procedure Append (Target : in out Variable_String; Source : Character);
procedure Append (Target : in out Variable_String;
Source : Character;
Count : Natural);
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Variable_String);
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : String);
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Character);
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Character;
Count : Natural);
procedure Delete (Target : in out Variable_String;
At_Pos : Positive;
Count : Natural := 1);
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Character);
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Character;
Count : Natural);
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : String);
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Variable_String);
-- Truncate or extend with fill
procedure Set_Length (Target : in out Variable_String;
New_Length : Natural;
Fill_With : Character := ' ');
-- Get information about or contents of a string
function Length (Source : Variable_String) return Natural;
function Char_At (Source : Variable_String; At_Pos : Positive)
return Character;
function Extract (Source : Variable_String;
Start_Pos : Positive;
End_Pos : Natural) return String;
-- get the allocated length of the string
function Max_Length (Source : Variable_String) return Natural;
pragma Inline (Length);
pragma Inline (Char_At);
pragma Inline (Max_Length);
private
type Variable_String (Maximum_Length : String_Length) is
record
Length : String_Length := 0;
Contents : String (1 .. Maximum_Length);
end record;
end Bounded_String;
package body Bounded_String is
procedure Copy (Target : in out Variable_String;
Source : Variable_String) is
begin
Target.Contents (1 .. Source.Length) :=
Source.Contents (1 .. Source.Length);
Target.Length := Source.Length;
end Copy;
procedure Copy (Target : in out Variable_String; Source : String) is
begin
Target.Contents (1 .. Source'Length) := Source;
Target.Length := Source'Length;
end Copy;
procedure Copy (Target : in out Variable_String; Source : Character) is
begin
Target.Contents (1) := Source;
Target.Length := 1;
end Copy;
procedure Move (Target : in out Variable_String;
Source : in out Variable_String) is
begin
Target.Contents (1 .. Source.Length) :=
Source.Contents (1 .. Source.Length);
Target.Length := Source.Length;
Source.Length := 0;
end Move;
function Image (V : Variable_String) return String is
begin
return V.Contents (1 .. V.Length);
end Image;
function Value (S : String; Max_Length : Natural) return Variable_String is
String_Value : String (1 .. Max_Length);
begin
String_Value (1 .. S'Length) := S;
return Variable_String'(Maximum_Length => Max_Length,
Length => S'Length,
Contents => String_Value);
end Value;
function Value (S : String) return Variable_String is
begin
return Variable_String'(Maximum_Length => S'Length,
Length => S'Length,
Contents => S);
end Value;
procedure Free (V : in out Variable_String) is
begin
V.Length := 0;
end Free;
procedure Append (Target : in out Variable_String; Source : String) is
Len : Natural := Target.Length + Source'Length;
begin
Target.Contents (Target.Length + 1 .. Len) := Source;
Target.Length := Len;
end Append;
procedure Append (Target : in out Variable_String;
Source : Variable_String) is
begin
Append (Target, Image (Source));
end Append;
procedure Append (Target : in out Variable_String; Source : Character) is
Len : Natural := Target.Length + 1;
begin
Target.Contents (Len) := Source;
Target.Length := Len;
end Append;
procedure Append (Target : in out Variable_String;
Source : Character;
Count : Natural) is
Value_String : String (1 .. Count) := String'(1 .. Count => Source);
begin
Append (Target, Value_String);
end Append;
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : String) is
begin
if At_Pos = Target.Length + 1 then
Append (Target, Source);
elsif At_Pos <= Target.Length then
declare
Len : Natural := Target.Length + Source'Length;
begin
Target.Contents (At_Pos .. Len) :=
Source & Target.Contents (At_Pos .. Target.Length);
Target.Length := Len;
end;
else
raise Constraint_Error;
end if;
end Insert;
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Variable_String) is
begin
Insert (Target, At_Pos, Source.Contents (1 .. Source.Length));
end Insert;
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Character) is
New_Len : Natural := Target.Length + 1;
begin
if At_Pos = New_Len then
Append (Target, Source);
elsif At_Pos > New_Len then
raise Constraint_Error;
else
Target.Contents (At_Pos + 1 .. New_Len) :=
Target.Contents (At_Pos .. Target.Length);
Target.Contents (At_Pos) := Source;
Target.Length := New_Len;
end if;
end Insert;
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Character;
Count : Natural) is
Value_String : String (1 .. Count) := String'(1 .. Count => Source);
begin
Insert (Target, At_Pos, Value_String);
end Insert;
procedure Delete (Target : in out Variable_String;
At_Pos : Positive;
Count : Natural := 1) is
Len : Natural := Target.Length - Count;
begin
if At_Pos - 1 > Len then
raise Constraint_Error;
end if;
if At_Pos <= Len then
Target.Contents (At_Pos .. Len) :=
Target.Contents (At_Pos + Count .. Target.Length);
end if;
Target.Length := Len;
end Delete;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Character) is
begin
if At_Pos > Target.Length then
raise Constraint_Error;
else
Target.Contents (At_Pos) := Source;
end if;
end Replace;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : String) is
End_Pos : constant Positive := At_Pos + Source'Length - 1;
begin
if End_Pos > Target.Length then
raise Constraint_Error;
else
Target.Contents (At_Pos .. End_Pos) := Source;
end if;
end Replace;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Character;
Count : Natural) is
Value_String : String (1 .. Count) := String'(1 .. Count => Source);
begin
Replace (Target, At_Pos, Value_String);
end Replace;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Variable_String) is
begin
Replace (Target, At_Pos, Image (Source));
end Replace;
procedure Set_Length (Target : in out Variable_String;
New_Length : Natural;
Fill_With : Character := ' ') is
Current_Length : Natural := Target.Length;
begin
for I in Current_Length + 1 .. New_Length loop
Target.Contents (I) := Fill_With;
end loop;
Target.Length := New_Length;
end Set_Length;
function Length (Source : Variable_String) return Natural is
begin
return Source.Length;
end Length;
function Max_Length (Source : Variable_String) return Natural is
begin
return Source.Maximum_Length;
end Max_Length;
function Char_At (Source : Variable_String; At_Pos : Positive)
return Character is
begin
if At_Pos > Source.Length then
raise Constraint_Error;
else
return Source.Contents (At_Pos);
end if;
end Char_At;
function Extract (Source : Variable_String;
Start_Pos : Positive;
End_Pos : Natural) return String is
begin
if End_Pos > Source.Length then
raise Constraint_Error;
else
return Source.Contents (Start_Pos .. End_Pos);
end if;
end Extract;
end Bounded_String;
generic
type ItemType is private; --| This is the data being manipulated.
with function Equal ( X,Y: in ItemType) return boolean is "=";
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;
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;
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;
--------------------------------------------------------------------------
------------------------------------------------------------------------
-- <UNIT> Token_Pkg
------------------------------------------------------------------------
--
-- <DESCRIPTION> This package defines types and operations for working
-- with tokens.
--
-- <AUTHOR> Barthe Raphael, Beck Didier, Kempe Laurent
-- <VERSION> 1.0
-- <DATE> 05-Jan-95
-- <MODIFY> 05-Jan-95
--
-- <PKG USED>
------------------------------------------------------------------------
package Token_Pkg is
type token is (T_Vrai, T_Faux,
T_Mais, T_Peut, T_Etre, T_Constitue, T_De, T_Dans, T_La, T_Piece, T_Est,
T_Ou, T_Et, T_Non,
T_Si, T_Alors, T_Fin_si, T_Vaut,
T_Dire, T_Jeu_Termine,
T_Directions, T_Pieces, T_Objets, T_Liens, T_Pnjs, T_Hero, T_Actions,
T_Scenario, T_Generales, T_Locales, T_Pseudo_generales,
T_Piece_courante, T_Objet, T_Pnj, T_Direction, T_Lien,
T_Add, T_Sub, T_Mul, T_Div, T_Quote, T_Comma, T_Colon, T_Ident,
T_Integer,
T_Eof, T_unk, T_verbes, T_END
);
function IsKeyWord (word : in STRING) return BOOLEAN;
function To_Token (word : in STRING) return token;
end Token_Pkg;
package body Token_Pkg is
type keywords is (VRAI, FAUX,
MAIS, PEUT, ETRE, CONSTITUE, DE, DANS, LA, PIECE, EST,
OU, ET, NON,
SI, ALORS, FIN_SI, VAUT,
DIRE, JEU_TERMINE,
DIRECTIONS, PIECES, OBJETS, LIENS, PNJS, HERO, ACTIONS, SCENARIO,
GENERALES, LOCALES, PSEUDO_GENERALES,
PIECE_COURANTE, OBJET, PNJ, DIRECTION, LIEN
);
function IsKeyWord (word : in STRING) return BOOLEAN is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> IsKeyWord
--
-- <DESCRIPTION> check if the string in input is a keyword of the langage.
--
-- <EXCEPTIONS> Nothing
--
--------------------------------------------------------------------------------
k : keywords;
begin
-- Mettre la chaine word en MAJUSCULE
k := keywords'VALUE(word);
return TRUE;
exception
when CONSTRAINT_ERROR => return FALSE;
end IsKeyWord;
function To_Token (word : in STRING) return token is
--------------------------------------------------------------------------------
-- <SUBPROGRAM>
-- <UNIT> To_Token
--
-- <DESCRIPTION> convert a string to a token.
--
-- <EXCEPTIONS> Nothing
--
--------------------------------------------------------------------------------
begin
return( token'VAL(keywords'POS(keywords'VALUE(word))) );
end To_Token;
end Token_Pkg;
with BOUNDED_STRING,CHARACTER_UTILITIES;
Package INT_LEX is
SubType I_String is BOUNDED_STRING.Variable_String(32);
type Int_State is (ST_Start, ST_Word, ST_sep, ST_unk);
Type Give_up_Words is (le,la,un,une,dans,sur,avec,a);
L_UND : Constant CHARACTER := '_';
L_SEP : Constant CHARACTER := ' ';
PROCEDURE Get (Command : in STRING; max : in Natural; pos : in out Natural; result : in out I_String);
End INT_LEX;
Package Body INT_LEX is
PROCEDURE Get (Command : in STRING; max : in natural; pos : in out Natural; result : in out I_String) is
index : natural:=1;
state : Int_state:=ST_START;
current : CHARACTER;
Found, Stop : Boolean := FALSE;
Begin
BOUNDED_STRING.COPY(result,"");
while (Not(Stop) and (pos<=max)) loop
current := command(pos);
Character_Utilities.Make_Lowercase(current);
case State is
when ST_START => if current in Character_Utilities.Lowercase_Character then
state := ST_WORD;
elsif current = L_SEP then
State := ST_SEP;
else
State := ST_UNK;
Stop := True;
end if;
when ST_WORD => if (current in Character_Utilities.Lowercase_Character
or
current = L_UND) then
BOUNDED_STRING.Append(Result,current);
pos := pos + 1;
else
Stop:=True;
end if;
when ST_SEP => if current = L_SEP then
pos := pos + 1;
else
State := ST_START;
end if;
when ST_UNK => Stop := True;
end case;
end loop;
end Get;
End INT_LEX;
with Token_Pkg,BOUNDED_STRING,INT_LEX,Lists;
Package INT_LIB is
SubType I_String is BOUNDED_STRING.Variable_String(10);
Nothing : Constant Natural := 0;
FUNCTION Egal (left,right : in I_String) Return Boolean;
Package Int_List is new Lists(
ItemType => I_String,
Egal
) ;
Type I_Table is Array (Positive range <>) of I_String; --INT_LIST.List;
FUNCTION Find(In_The_Table : in I_Table;
The_String : in I_String) return Natural;
PROCEDURE Parse_Verb( In_String : in String ;
Size : in Natural;
At_pos : in out Natural;
In_Table : in I_Table;
Verb_Index : out Natural );
end INT_LIB;
Package body INT_LIB is
FUNCTION Find(In_The_Table : in I_Table ;
The_String : in I_String ) return Natural is
Begin
For i in In_The_Table'RANGE
Loop
If Int_List.IsInList(In_The_Table(i),The_String) then
return NATURAL'VAL(i);
End if;
End loop;
Return Nothing;
End Find;
FUNCTION Egal (left,right : in I_String) return Boolean is
Begin
Return BOUNDED_STRING.Image(left) = BOUNDED_STRING.Image(Right);
End Egal;
PROCEDURE Parse_Verb( In_String : in String ;
Size : in Natural;
At_pos : in out Natural;
In_Table : in I_Table;
Verb_Index : out Natural) is
Extracted_string : I_String;
Index : Natural := Nothing;
Begin
INT_LEX.GET(In_string,Size,at_pos,Extracted_String);
Verb_Index := FIND(In_Table,Extracted_String);
End Parse_verb;
end INT_LIB