|
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 - 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