|
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: 228267 (0x37bab)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦cb4012ff5⟧
└─⟦this⟧
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
Size : Integer;
-- number of buckets
type Domain_Type is private;
type Range_Type is private;
-- both types are pure values
-- no initialization or finalization is necessary
-- = and := can be used for equality and copy
with function Hash (Key : Domain_Type) return Integer is <>;
-- for efficiency, spread hash over an interval at least as great as size
pragma Must_Be_Constrained (Yes => Domain_Type, Range_Type);
package Concurrent_Map_Generic is
type Map is private;
type Pair is
record
D : Domain_Type;
R : Range_Type;
end record;
function Eval (The_Map : Map; D : Domain_Type) return Range_Type;
procedure Find (The_Map : Map;
D : Domain_Type;
R : in out Range_Type;
Success : out Boolean);
procedure Find (The_Map : Map;
D : Domain_Type;
P : in out Pair;
Success : out Boolean);
procedure Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False);
procedure Undefine (The_Map : in out Map; D : Domain_Type);
procedure Initialize (The_Map : out Map);
function Is_Empty (The_Map : Map) return Boolean;
procedure Make_Empty (The_Map : in out Map);
procedure Copy (Target : in out Map; Source : Map);
type Iterator is private;
procedure Init (Iter : out Iterator; The_Map : Map);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Domain_Type;
function Done (Iter : Iterator) return Boolean;
Undefined : exception;
-- raised by eval if the domain value in not in the map
Multiply_Defined : exception;
-- raised by define if the domain value is already defined and
-- the trap_multiples flag has been specified (ie. is true)
function Nil return Map;
function Is_Nil (The_Map : Map) return Boolean;
function Cardinality (The_Map : Map) return Natural;
------------------------------------------------------
-- Implementation Notes and Non-Standard Operations --
------------------------------------------------------
-- := and = operate on references
-- := implies sharing (introduces an alias)
-- = means is the same map, not the same value of type map
-- Initializing a map also makes it empty
-- Maps must be initialized before use.
-- garbage may be generated
-- Concurrent Properties
-- any number of find/eval/is_empty/copy may be safely done while one
-- define/undefine/make_empty is taking place.
-- Define/undefine/make_empty operations are serialized.
-- Iterators may be used asynchronously, however the sequence of values
-- yielded may never have been in the map at any one time.
private
type Node;
type Set is access Node;
type Node is
record
Value : Pair;
Link : Set;
end record;
type Map_Data;
type Map is access Map_Data;
type Iterator is
record
The_Map : Map;
Index_Value : Natural;
Set_Iter : Set;
Done : Boolean;
end record;
subtype Index is Integer range 0 .. Size - 1;
type Table is array (Index) of Set;
type Map_Data is
record
Cache : Set; -- of at most one node
Bucket : Table;
Size : Natural := 0;
end record;
end Concurrent_Map_Generic;package body Concurrent_Map_Generic is
task Serialize is
entry Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False);
entry Undefine (The_Map : in out Map; D : Domain_Type);
entry Make_Empty (The_Map : in out Map);
end Serialize;
function Myhash (D : Domain_Type) return Index is
begin
return Index (Hash (D) mod Size);
end Myhash;
pragma Inline (Myhash);
function Find (The_Map : Map; D : Domain_Type) return Set is
-- result = null ==> D not in S
Rest : Set := The_Map.Bucket (Myhash (D));
begin
while Rest /= null and then Rest.Value.D /= D loop
Rest := Rest.Link;
end loop;
if Rest /= null then
The_Map.Cache := Rest;
end if;
return Rest;
end Find;
procedure Find (S : Set;
D : Domain_Type;
Ptr : in out Set;
Prev : in out Set) is
-- ptr = null ==> D not in S
-- ptr /= null and prev = null ==> D = first element of S
begin
Ptr := S;
Prev := null;
while (Ptr /= null) and then (Ptr.Value.D /= D) loop
Prev := Ptr;
Ptr := Ptr.Link;
end loop;
end Find;
function Eval (The_Map : Map; D : Domain_Type) return Range_Type is
Cache : Set := The_Map.Cache;
-- cached pointer value must be fetched only once
-- since cache may be concurrently updated
begin
if Cache /= null then
declare
Value : Pair renames Cache.Value;
begin
if Value.D = D then
return Value.R;
end if;
end;
end if;
declare
Ptr : Set := Find (The_Map, D);
begin
if Ptr /= null then
return Ptr.Value.R;
else
raise Undefined;
end if;
end;
end Eval;
procedure Find (The_Map : Map;
D : Domain_Type;
R : in out Range_Type;
Success : out Boolean) is
Cache : Set := The_Map.Cache;
-- cached pointer value must be fetched only once
-- since cache may be concurrently updated
begin
if Cache /= null then
declare
Value : Pair renames Cache.Value;
begin
if Value.D = D then
R := Value.R;
Success := True;
return;
end if;
end;
end if;
declare
Ptr : Set := Find (The_Map, D);
begin
if Ptr /= null then
R := Ptr.Value.R;
Success := True;
else
Success := False;
end if;
end;
end Find;
procedure Find (The_Map : Map;
D : Domain_Type;
P : in out Pair;
Success : out Boolean) is
Cache : Set := The_Map.Cache;
-- cached pointer value must be fetched only once
-- since cache may be concurrently updated
begin
if Cache /= null then
declare
Value : Pair renames Cache.Value;
begin
if Value.D = D then
P := Value;
Success := True;
return;
end if;
end;
end if;
declare
Ptr : Set := Find (The_Map, D);
begin
if Ptr /= null then
P := Ptr.Value;
Success := True;
else
Success := False;
end if;
end;
end Find;
procedure Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False) is
begin
Serialize.Define (The_Map, D, R, Trap_Multiples);
end Define;
procedure Real_Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False) is
Cache : Set renames The_Map.Cache;
-- cache can be written but not fetched
-- since cache may be concurrently updated
The_Set : Set renames The_Map.Bucket (Myhash (D));
Ptr : Set;
Prev : Set;
begin
Find (The_Set, D, Ptr, Prev);
if Ptr = null then
The_Set := new Node'(Pair'(D => D, R => R), The_Set);
Cache := The_Set;
The_Map.Size := The_Map.Size + 1;
elsif Trap_Multiples then
raise Multiply_Defined;
elsif Prev = null then
The_Set := new Node'(Pair'(D => D, R => R), Ptr.Link);
Cache := The_Set;
else
Prev.Link := new Node'(Pair'(D => D, R => R), Ptr.Link);
Cache := Prev.Link;
end if;
end Real_Define;
procedure Undefine (The_Map : in out Map; D : Domain_Type) is
begin
Serialize.Undefine (The_Map, D);
end Undefine;
procedure Real_Undefine (The_Map : in out Map; D : Domain_Type) is
Cache : Set renames The_Map.Cache;
-- cache must be written but not fetched
-- since cache may be concurrently updated
Start : Set renames The_Map.Bucket (Myhash (D));
Current : Set;
Previous : Set;
begin
Find (Start, D, Current, Previous);
if Current = null then
raise Undefined;
elsif Previous = null then
-- old node cannot be reused due to concurrent readers
Start := Current.Link;
else
-- old node cannot be reused due to concurrent readers
Previous.Link := Current.Link;
end if;
The_Map.Size := The_Map.Size - 1;
Cache := null;
end Real_Undefine;
procedure Copy (Target : in out Map; Source : Map) is
procedure Copy_Set (Target_Set : in out Set; Source_Set : Set) is
Rest : Set := Source_Set;
begin
Target_Set := null;
while Rest /= null loop
Target_Set := new Node'(Rest.Value, Target_Set);
Target.Size := Target.Size + 1;
Rest := Rest.Link;
end loop;
end Copy_Set;
begin
Target.Size := 0;
for I in Index loop
Copy_Set (Target_Set => Target.Bucket (I),
Source_Set => Source.Bucket (I));
end loop;
Target.Cache := null;
end Copy;
procedure Initialize (The_Map : out Map) is
begin
The_Map := new Map_Data;
end Initialize;
function Is_Empty (The_Map : Map) return Boolean is
begin
for I in Index loop
if The_Map.Bucket (I) /= null then
return False;
end if;
end loop;
return True;
end Is_Empty;
procedure Make_Empty (The_Map : in out Map) is
begin
Serialize.Make_Empty (The_Map);
end Make_Empty;
procedure Real_Make_Empty (The_Map : in out Map) is
begin
The_Map.Cache := null;
for I in Index loop
The_Map.Bucket (I) := null;
end loop;
end Real_Make_Empty;
procedure Init (Iter : out Iterator; The_Map : Map) is
The_Iter : Iterator;
begin
if The_Map = null then
Iter.Done := True;
return;
end if;
for I in Index loop
The_Iter.Set_Iter := The_Map.Bucket (I);
if The_Iter.Set_Iter /= null then
The_Iter.Done := False;
The_Iter.Index_Value := I;
The_Iter.The_Map := The_Map;
Iter := The_Iter;
return;
end if;
end loop;
The_Iter.Done := True;
Iter := The_Iter;
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter.Set_Iter := Iter.Set_Iter.Link;
while Iter.Set_Iter = null loop
if Iter.Index_Value = Index'Last then
Iter.Done := True;
return;
end if;
Iter.Index_Value := Iter.Index_Value + 1;
Iter.Set_Iter := Iter.The_Map.Bucket (Iter.Index_Value);
end loop;
end Next;
function Value (Iter : Iterator) return Domain_Type is
begin
return Iter.Set_Iter.Value.D;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter.Done;
end Done;
task body Serialize is
begin
loop
begin
select
accept Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False) do
Real_Define (The_Map, D, R, Trap_Multiples);
end Define;
or
accept Undefine (The_Map : in out Map; D : Domain_Type) do
Real_Undefine (The_Map, D);
end Undefine;
or
accept Make_Empty (The_Map : in out Map) do
Real_Make_Empty (The_Map);
end Make_Empty;
or
terminate;
end select;
exception
when others =>
null;
end;
end loop;
end Serialize;
function Nil return Map is
begin
return null;
end Nil;
function Is_Nil (The_Map : Map) return Boolean is
begin
return The_Map = null;
end Is_Nil;
function Cardinality (The_Map : Map) return Natural is
begin
return The_Map.Size;
end Cardinality;
end Concurrent_Map_Generic;with Floating_Characteristics;
use Floating_Characteristics;
package Core_Functions is
Exp_Large : Float;
Exp_Small : Float;
function Sqrt (X : Float) return Float;
function Cbrt (X : Float) return Float;
function Log (X : Float) return Float;
function Log10 (X : Float) return Float;
function Exp (X : Float) return Float;
function "**" (X, Y : Float) return Float;
end Core_Functions;with Text_Io;
use Text_Io;
with Floating_Characteristics;
use Floating_Characteristics;
with Numeric_Io;
use Numeric_Io;
with Numeric_Primitives;
use Numeric_Primitives;
package body Core_Functions is
-- The following routines are coded directly from the algorithms and
-- coeficients given in "Software Manual for the Elementry Functions"
-- by William J. Cody, Jr. and William Waite, Prentice_Hall, 1980
-- CBRT by analogy
-- A more general formulation uses MANTISSA_TYPE, etc.
-- The coeficients are appropriate for 25 to 32 bits floating significance
-- They will work for less but slightly shorter versions are possible
-- The routines are coded to stand alone so they need not be compiled together
-- These routines have been coded to accept a general MANTISSA_TYPE
-- That is, they are designed to work with a manitssa either fixed of float
-- There are some explicit conversions which are required but these will
-- not cause any extra code to be generated
-- 16 JULY 1982 W A WHITAKER AFATL EGLIN AFB FL 32542
-- T C EICHOLTZ USAFA
function Sqrt (X : Float) return Float is
M, N : Exponent_Type;
F, Y : Mantissa_Type;
Result : Float;
subtype Index is Integer range 0 ..
100; -- #########################
Sqrt_L1 : Index := 3;
-- Could get away with SQRT_L1 := 2 for 28 bits
-- Using the better Cody-Waite coeficients overflows MANTISSA_TYPE
Sqrt_C1 : Mantissa_Type := 8#0.3317777777#;
Sqrt_C2 : Mantissa_Type := 8#0.4460000000#;
Sqrt_C3 : Mantissa_Type := 8#0.55202_36314_77747_36311_0#;
begin
if X = Zero then
Result := Zero;
return Result;
elsif X = One then
-- To get exact SQRT(1.0)
Result := One;
return Result;
elsif X < Zero then
New_Line;
Put ("CALLED SQRT FOR NEGATIVE ARGUMENT ");
raise Program_Error;
--Put (X);
Put (" USED ABSOLUTE VALUE");
New_Line;
Result := Sqrt (abs (X));
return Result;
else
Defloat (X, N, F);
Y := Sqrt_C1 + Mantissa_Type (Sqrt_C2 * F);
for J in 1 .. Sqrt_L1 loop
Y := Y / Mantissa_Divisor_2 + Mantissa_Type
((F / Mantissa_Divisor_2) / Y);
end loop;
if (N mod 2) /= 0 then
Y := Mantissa_Type (Sqrt_C3 * Y);
N := N + 1;
end if;
M := N / 2;
Refloat (M, Y, Result);
return Result;
end if;
exception
when others =>
New_Line;
Put (" EXCEPTION IN SQRT, X = ");
raise Program_Error;
--Put (X);
Put (" RETURNED 1.0");
New_Line;
return One;
end Sqrt;
function Cbrt (X : Float) return Float is
M, N : Exponent_Type;
F, Y : Mantissa_Type;
Result : Float;
subtype Index is Integer range 0 ..
100; -- #########################
Cbrt_L1 : Index := 3;
Cbrt_C1 : Mantissa_Type := 0.5874009;
Cbrt_C2 : Mantissa_Type := 0.4125990;
Cbrt_C3 : Mantissa_Type := 0.62996_05249;
Cbrt_C4 : Mantissa_Type := 0.79370_05260;
begin
if X = Zero then
Result := Zero;
return Result;
else
Defloat (X, N, F);
F := abs (F);
Y := Cbrt_C1 + Mantissa_Type (Cbrt_C2 * F);
for J in 1 .. Cbrt_L1 loop
Y := Y - (Y / Mantissa_Divisor_3 -
Mantissa_Type ((F / Mantissa_Divisor_3) /
Mantissa_Type (Y * Y)));
end loop;
case (N mod 3) is
when 0 =>
null;
when 1 =>
Y := Mantissa_Type (Cbrt_C3 * Y);
N := N + 2;
when 2 =>
Y := Mantissa_Type (Cbrt_C4 * Y);
N := N + 1;
when others =>
null;
end case;
M := N / 3;
if X < Zero then
Y := -Y;
end if;
Refloat (M, Y, Result);
return Result;
end if;
exception
when others =>
Result := One;
if X < Zero then
Result := -One;
end if;
New_Line;
Put ("EXCEPTION IN CBRT, X = ");
raise Program_Error;
--Put (X);
Put (" RETURNED ");
raise Program_Error;
--Put (Result);
New_Line;
return Result;
end Cbrt;
function Log (X : Float) return Float is
-- Uses fixed formulation for generality
Result : Float;
N : Exponent_Type;
Xn : Float;
Y : Float;
F : Mantissa_Type;
Z, Zden, Znum : Mantissa_Type;
C0 : constant Mantissa_Type := 0.20710_67811_86547_52440;
-- SQRT(0.5) - 0.5
C1 : constant Float := 8#0.543#;
C2 : constant Float := -2.12194_44005_46905_82767_9E-4;
function R (Z : Mantissa_Type) return Mantissa_Type is
-- Use fixed formulation here because the float coeficents are > 1.0
-- and would exceed the limits on a MANTISSA_TYPE
A0 : constant Mantissa_Type := 0.04862_85276_587;
B0 : constant Mantissa_Type := 0.69735_92187_803;
B1 : constant Mantissa_Type := -0.125;
C : constant Mantissa_Type := 0.01360_09546_862;
begin
return Z + Mantissa_Type
(Z * Mantissa_Type
(Mantissa_Type (Z * Z) *
(C + Mantissa_Type
(A0 / (B0 +
Mantissa_Type
(B1 * Mantissa_Type
(Z * Z)))))));
end R;
begin
if X < Zero then
New_Line;
Put ("CALLED LOG FOR NEGATIVE ");
raise Program_Error; --put (X);;
Put (" USE ABS => ");
Result := Log (abs (X));
raise Program_Error;
--Put (Result);
New_Line;
elsif X = Zero then
New_Line;
Put ("CALLED LOG FOR ZERO ARGUMENT, RETURNED ");
Result := -Xmax; -- SUPPOSED TO BE -LARGE
raise Program_Error;--Put (Result);
New_Line;
else
Defloat (X, N, F);
Znum := F - Mantissa_Half;
Y := Convert_To_Float (Znum);
Zden := Znum / Mantissa_Divisor_2 + Mantissa_Half;
if Znum > C0 then
Y := Y - Mantissa_Half;
Znum := Znum - Mantissa_Half;
Zden := Zden + Mantissa_Half / Mantissa_Divisor_2;
else
N := N - 1;
end if;
Z := Mantissa_Type (Znum / Zden);
Result := Convert_To_Float (R (Z));
if N /= 0 then
Xn := Convert_To_Float (N);
Result := (Xn * C2 + Result) + Xn * C1;
end if;
end if;
return Result;
exception
when others =>
New_Line;
Put (" EXCEPTION IN LOG, X = ");
raise Program_Error; --put (X);;
Put (" RETURNED 0.0");
New_Line;
return Zero;
end Log;
function Log10 (X : Float) return Float is
Log_10_Of_2 : constant Float :=
Convert_To_Float (Mantissa_Type (
8#0.33626_75425_11562_41615#));
begin
return Log (X) * Log_10_Of_2;
end Log10;
function Exp (X : Float) return Float is
Result : Float;
N : Exponent_Type;
Xg, Xn, X1, X2 : Float;
F, G : Mantissa_Type;
Bigx : Float := Exp_Large;
Smallx : Float := Exp_Small;
One_Over_Log_2 : constant Float := 1.4426_95040_88896_34074;
C1 : constant Float := 0.69335_9375;
C2 : constant Float := -2.1219_44400_54690_58277E-4;
function R (G : Mantissa_Type) return Mantissa_Type is
Z, Gp, Q : Mantissa_Type;
P0 : constant Mantissa_Type := 0.24999_99999_9992;
P1 : constant Mantissa_Type := 0.00595_04254_9776;
Q0 : constant Mantissa_Type := 0.5;
Q1 : constant Mantissa_Type := 0.05356_75176_4522;
Q2 : constant Mantissa_Type := 0.00029_72936_3682;
begin
Z := Mantissa_Type (G * G);
Gp := Mantissa_Type ((Mantissa_Type (P1 * Z) + P0) * G);
Q := Mantissa_Type ((Mantissa_Type (Q2 * Z) + Q1) * Z) + Q0;
return Mantissa_Half + Mantissa_Type (Gp / (Q - Gp));
end R;
begin
if X > Bigx then
New_Line;
Put (" EXP CALLED WITH TOO BIG A POSITIVE ARGUMENT, ");
raise Program_Error; --put (X);;
Put (" RETURNED XMAX");
New_Line;
Result := Xmax;
elsif X < Smallx then
New_Line;
Put (" EXP CALLED WITH TOO BIG A NEGATIVE ARGUMENT, ");
raise Program_Error; --put (X);;
Put (" RETURNED ZERO");
New_Line;
Result := Zero;
elsif abs (X) < Eps then
Result := One;
else
N := Exponent_Type (X * One_Over_Log_2);
Xn := Convert_To_Float (N);
X1 := Round (X);
X2 := X - X1;
Xg := ((X1 - Xn * C1) + X2) - Xn * C2;
G := Mantissa_Type (Xg);
N := N + 1;
F := R (G);
Refloat (N, F, Result);
end if;
return Result;
exception
when others =>
New_Line;
Put (" EXCEPTION IN EXP, X = ");
raise Program_Error; --put (X);;
Put (" RETURNED 1.0");
New_Line;
return One;
end Exp;
function "**" (X, Y : Float) return Float is
-- This is the last function to be coded since it appeared that it really
-- was un-Ada-like and ought not be in the regular package
-- Nevertheless it was included in this version
-- It is specific for FLOAT and does not have the MANTISSA_TYPE generality
M, N : Exponent_Type;
G : Mantissa_Type;
P, Temp, Iw1, I : Integer;
Result, Z, V, R, U1, U2, W, W1, W2, W3, Y1, Y2 : Float;
K : constant Float := 0.44269_50408_88963_40736;
Ibigx : constant Integer := Integer
(Truncate (16.0 * Log (Xmax) - 1.0));
Ismallx : constant Integer := Integer
(Truncate (16.0 * Log (Xmin) + 1.0));
P1 : constant Float := 0.83333_32862_45E-1;
P2 : constant Float := 0.12506_48500_52E-1;
Q1 : constant Float := 0.69314_71805_56341;
Q2 : constant Float := 0.24022_65061_44710;
Q3 : constant Float := 0.55504_04881_30765E-1;
Q4 : constant Float := 0.96162_06595_83789E-2;
Q5 : constant Float := 0.13052_55159_42810E-2;
A1 : array (1 .. 17) of Float :=
(8#1.00000_0000#, 8#0.75222_5750#, 8#0.72540_3067#, 8#0.70146_3367#,
8#0.65642_3746#, 8#0.63422_2140#, 8#0.61263_4520#, 8#0.57204_2434#,
8#0.55202_3631#, 8#0.53254_0767#, 8#0.51377_3265#,
8#0.47572_4623#, 8#0.46033_7602#, 8#0.44341_7233#,
8#0.42712_7017#, 8#0.41325_3033#, 8#0.40000_0000#);
A2 : array (1 .. 8) of Float :=
(8#0.00000_00005_22220_66302_61734_72062#,
8#0.00000_00003_02522_47021_04062_61124#,
8#0.00000_00005_21760_44016_17421_53016#,
8#0.00000_00007_65401_41553_72504_02177#,
8#0.00000_00002_44124_12254_31114_01243#,
8#0.00000_00000_11064_10432_66404_42174#,
8#0.00000_00004_72542_16063_30176_55544#,
8#0.00000_00001_74611_03661_23056_22556#);
function Reduce (V : Float) return Float is
begin
return Float (Integer (16.0 * V)) * 0.0625;
end Reduce;
begin
if X <= Zero then
if X < Zero then
Result := (abs (X)) ** Y;
New_Line;
Put ("X**Y CALLED WITH X = ");
raise Program_Error; --put (X);
New_Line;
Put ("USED ABS, RETURNED ");
raise Program_Error;--Put (Result);
New_Line;
else
if Y <= Zero then
if Y = Zero then
Result := Zero;
else
Result := Xmax;
end if;
New_Line;
Put ("X**Y CALLED WITH X = 0, Y = ");
raise Program_Error; --put (Y);
New_Line;
Put ("RETURNED ");
raise Program_Error;--Put (Result);
New_Line;
else
Result := Zero;
end if;
end if;
else
Defloat (X, M, G);
P := 1;
if G <= A1 (9) then
P := 9;
end if;
if G <= A1 (P + 4) then
P := P + 4;
end if;
if G <= A1 (P + 2) then
P := P + 2;
end if;
Z := ((G - A1 (P + 1)) - A2 ((P + 1) / 2)) / (G + A1 (P + 1));
Z := Z + Z;
V := Z * Z;
R := (P2 * V + P1) * V * Z;
R := R + K * R;
U2 := (R + Z * K) + Z;
U1 := Float (Integer (M) * 16 - P) * 0.0625;
Y1 := Reduce (Y);
Y2 := Y - Y1;
W := U2 * Y + U1 * Y2;
W1 := Reduce (W);
W2 := W - W1;
W := W1 + U1 * Y1;
W1 := Reduce (W);
W2 := W2 + (W - W1);
W3 := Reduce (W2);
Iw1 := Integer (Truncate (16.0 * (W1 + W3)));
W2 := W2 - W3;
if W > Float (Ibigx) then
Result := Xmax;
Put ("X**Y CALLED X =");
raise Program_Error; --put (X);
Put (" Y =");
raise Program_Error; --put (Y);
Put (" TOO LARGE RETURNED ");
raise Program_Error;--Put (Result);
New_Line;
elsif W < Float (Ismallx) then
Result := Zero;
Put ("X**Y CALLED X =");
raise Program_Error;
--put(X);
Put (" Y =");
raise Program_Error;
Put (" TOO SMALL RETURNED ");
raise Program_Error;--Put (Result);
New_Line;
else
if W2 > Zero then
W2 := W2 - 0.0625;
Iw1 := Iw1 + 1;
end if;
if Iw1 < Integer (Zero) then
I := 0;
else
I := 1;
end if;
M := Exponent_Type (I + Iw1 / 16);
P := 16 * Integer (M) - Iw1;
Z := ((((Q5 * W2 + Q4) * W2 + Q3) * W2 + Q2) * W2 + Q1) * W2;
Z := A1 (P + 1) + (A1 (P + 1) * Z);
Refloat (M, Z, Result);
end if;
end if;
return Result;
end "**";
begin
Exp_Large := Log (Xmax) * (One - Eps);
Exp_Small := Log (Xmin) * (One - Eps);
end Core_Functions;
generic
type Enumeration is (<>);
procedure Enumeration_Value (S : String;
Result : out Enumeration;
Prefix : out Boolean;
Unique : out Boolean);with String_Utilities;
procedure Enumeration_Value (S : String;
Result : out Enumeration;
Prefix : out Boolean;
Unique : out Boolean) is
Already_Matched : Boolean := False;
Exact : Boolean;
Match : Boolean;
Up_S : constant String := String_Utilities.Upper_Case (S);
begin
Prefix := False;
Unique := False;
Result := Enumeration'Last;
for Enum in Enumeration loop
declare
Enum_Image : constant String := Enumeration'Image (Enum);
begin
Match := Up_S'Length <= Enum_Image'Length and then
Up_S = Enum_Image (1 .. Up_S'Length);
Exact := Match and then (Up_S'Length = Enum_Image'Length);
end;
if Exact then
Result := Enum;
Unique := True;
Prefix := False;
return;
elsif Match then
Unique := not Already_Matched;
Already_Matched := True;
Prefix := True;
Result := Enum;
end if;
end loop;
end Enumeration_Value;package Floating_Characteristics is
-- This package is a floating mantissa definition of a binary FLOAT
-- It was first used on the DEC-10 and the VAX but should work for any
-- since the parameters are obtained by initializing on the actual hardware
-- Otherwise the parameters could be set in the spec if known
-- This is a preliminary package that defines the properties
-- of the particular floating point type for which we are going to
-- generate the math routines
-- The constants are those required by the routines described in
-- "Software Manual for the Elementary Functions" W. Cody & W. Waite
-- Prentice-Hall 1980
-- Actually most are needed only for the test programs
-- rather than the functions themselves, but might as well be here
-- Most of these could be in the form of attributes if
-- all the floating types to be considered were those built into the
-- compiler, but we also want to be able to support user defined types
-- such as software floating types of greater precision than
-- the hardware affords, or types defined on one machine to
-- simulate another
-- So we use the Cody-Waite names and derive them from an adaptation of the
-- MACHAR routine as given by Cody-Waite in Appendix B
--
Ibeta : Integer;
-- The radix of the floating-point representation
--
It : Integer;
-- The number of base IBETA digits in the DIS_FLOAT significand
--
Irnd : Integer;
-- TRUE (1) if floating addition rounds, FALSE (0) if truncates
--
Ngrd : Integer;
-- Number of guard digits for multiplication
--
Machep : Integer;
-- The largest negative integer such that
-- 1.0 + FLOAT(IBETA) ** MACHEP /= 1.0
-- except that MACHEP is bounded below by -(IT + 3)
--
Negep : Integer;
-- The largest negative integer such that
-- 1.0 -0 FLOAT(IBETA) ** NEGEP /= 1.0
-- except that NEGEP is bounded below by -(IT + 3)
--
Iexp : Integer;
-- The number of bits (decimal places if IBETA = 10)
-- reserved for the representation of the exponent (including
-- the bias or sign) of a floating-point number
--
Minexp : Integer;
-- The largest in magnitude negative integer such that
-- FLOAT(IBETA) ** MINEXP is a positive floating-point number
--
Maxexp : Integer;
-- The largest positive exponent for a finite floating-point number
--
Eps : Float;
-- The smallest positive floating-point number such that
-- 1.0 + EPS /= 1.0
-- In particular, if IBETA = 2 or IRND = 0,
-- EPS = FLOAT(IBETA) ** MACHEP
-- Otherwise, EPS = (FLOAT(IBETA) ** MACHEP) / 2
--
Epsneg : Float;
-- A small positive floating-point number such that 1.0-EPSNEG /= 1.0
--
Xmin : Float;
-- The smallest non-vanishing floating-point power of the radix
-- In particular, XMIN = FLOAT(IBETA) ** MINEXP
--
Xmax : Float;
-- The largest finite floating-point number
-- Here the structure of the floating type is defined
-- I have assumed that the exponent is always some integer form
-- The mantissa can vary
-- Most often it will be a fixed type or the same floating type
-- depending on the most efficient machine implementation
-- Most efficient implementation may require details of the machine hardware
-- In this version the simplest representation is used
-- The mantissa is extracted into a FLOAT and uses the predefined operations
--
subtype Exponent_Type is Integer; -- should be derived ##########
subtype Mantissa_Type is Float; -- range -1.0..1.0;
--
-- A consequence of the rigorous constraints on MANTISSA_TYPE is that
-- operations must be very carefully examined to make sure that no number
-- greater than one results
-- Actually this limitation is important in constructing algorithms
-- which will also run when MANTISSA_TYPE is a fixed point type
-- If we are not using the STANDARD type, we have to define all the
-- operations at this point
-- We also need PUT for the type if it is not otherwise available
-- Now we do something strange
-- Since we do not know in the following routines whether the mantissa
-- will be carried as a fixed or floating type, we have to make some
-- provision for dividing by two
-- We cannot use the literals, since FIXED/2.0 and FLOAT/2 will fail
-- We define a type-dependent factor that will work
--
Mantissa_Divisor_2 : constant Float := 2.0;
Mantissa_Divisor_3 : constant Float := 3.0;
--
-- This will work for the MANTISSA_TYPE defined above
-- The alternative of defining an operation "/" to take care of it
-- is too sweeping and would allow unAda-like errors
--
Mantissa_Half : constant Mantissa_Type := 0.5;
procedure Defloat (X : in Float;
N : in out Exponent_Type;
F : in out Mantissa_Type);
procedure Refloat (N : in Exponent_Type;
F : in Mantissa_Type;
X : in out Float);
-- Since the user may wish to define a floating type by some other name
-- CONVERT_TO_FLOAT is used rather than just FLOAT for explicit coersion
function Convert_To_Float (K : Integer) return Float;
-- function CONVERT_TO_FLOAT(N : EXPONENT_TYPE) return FLOAT;
function Convert_To_Float (F : Mantissa_Type) return Float;
end Floating_Characteristics;with Text_Io;
use Text_Io;
package body Floating_Characteristics is
-- This package is a floating mantissa definition of a binary FLOAT
A, B, Y, Z : Float;
I, K, Mx, Iz : Integer;
Beta, Betam1, Betain : Float;
One : Float := 1.0;
Zero : Float := 0.0;
procedure Defloat (X : in Float;
N : in out Exponent_Type;
F : in out Mantissa_Type) is
-- This is admittedly a slow method - but portable - for breaking down
-- a floating point number into its exponent and mantissa
-- Obviously with knowledge of the machine representation
-- it could be replaced with a couple of simple extractions
Exponent_Length : Integer := Iexp;
M : Exponent_Type;
W, Y, Z : Float;
begin
N := 0;
F := 0.0;
Y := abs (X);
if Y = 0.0 then
return;
elsif Y < 0.5 then
for J in reverse 0 .. (Exponent_Length - 2) loop
-- Dont want to go all the way to 2.0**(EXPONENT_LENGTH - 1)
-- Since that (or its reciprocal) will overflow if exponent biased
-- Ought to use talbular values rather than compute each time
M := Exponent_Type (2 ** J);
Z := 1.0 / (2.0 ** M);
W := Y / Z;
if W < 1.0 then
Y := W;
N := N - M;
end if;
end loop;
else
for J in reverse 0 .. (Exponent_Length - 2) loop
M := Exponent_Type (2 ** J);
Z := 2.0 ** M;
W := Y / Z;
if W >= 0.5 then
Y := W;
N := N + M;
end if;
end loop;
-- And just to clear up any loose ends from biased exponents
end if;
while Y < 0.5 loop
Y := Y * 2.0;
N := N - 1;
end loop;
while Y >= 1.0 loop
Y := Y / 2.0;
N := N + 1;
end loop;
F := Mantissa_Type (Y);
if X < 0.0 then
F := -F;
end if;
return;
exception
when others =>
N := 0;
F := 0.0;
return;
end Defloat;
procedure Refloat (N : in Exponent_Type;
F : in Mantissa_Type;
X : in out Float) is
-- Again a brute force method - but portable
-- Watch out near MAXEXP
M : Integer;
Y : Float;
begin
if F = 0.0 then
X := Zero;
return;
end if;
M := Integer (N);
Y := abs (Float (F));
while Y < 0.5 loop
M := M - 1;
if M < Minexp then
X := Zero;
end if;
Y := Y + Y;
exit when M <= Minexp;
end loop;
if M = Maxexp then
M := M - 1;
X := Y * 2.0 ** M;
X := X * 2.0;
elsif M <= Minexp + 2 then
M := M + 3;
X := Y * 2.0 ** M;
X := ((X / 2.0) / 2.0) / 2.0;
else
X := Y * 2.0 ** M;
end if;
if F < 0.0 then
X := -X;
end if;
return;
end Refloat;
function Convert_To_Float (K : Integer) return Float is
begin
return Float (K);
end Convert_To_Float;
-- function CONVERT_TO_FLOAT(N : EXPONENT_TYPE) RETURN FLOAT is
-- begin
-- RETURN FLOAT(N);
-- end CONVERT_TO_FLOAT;
function Convert_To_Float (F : Mantissa_Type) return Float is
begin
return Float (F);
end Convert_To_Float;
--
begin
-- Initialization for the VAX with values derived by MACHAR
-- In place of running MACHAR as the actual initialization
Ibeta := 2;
It := 24;
Irnd := 1;
Negep := -24;
Epsneg := 5.9604644E-008;
Machep := -24;
Eps := 5.9604644E-008;
Ngrd := 0;
Xmin := 5.9E-39;
Minexp := -126;
Iexp := 8;
Maxexp := 127;
Xmax := 8.5E37 * 2.0;
---- This initialization is the MACHAR routine of Cody and Waite Appendix B.
--PUT("INITIALIZATING WITH MACHAR - ");
-- A := ONE;
-- while (((A + ONE) - A) - ONE) = ZERO loop
-- A := A + A;
-- end loop;
-- B := ONE;
-- while ((A + B) - A) = ZERO loop
-- B := B + B;
-- end loop;
-- IBETA := INTEGER((A + B) - A);
-- BETA := CONVERT_TO_FLOAT(IBETA);
--
--
-- IT := 0;
-- B := ONE;
-- while (((B + ONE) - B) - ONE) = ZERO loop
-- IT := IT + 1;
-- B := B * BETA;
-- end loop;
--
--
-- IRND := 0;
-- BETAM1 := BETA - ONE;
-- if ((A + BETAM1) - A) /= ZERO then
-- IRND := 1;
-- end if;
--
--
-- NEGEP := IT + 3;
-- BETAIN := ONE / BETA;
-- A := ONE;
-- -- for I in 1..NEGEP loop
-- for I in 1..50 loop
-- exit when I > NEGEP;
-- A := A * BETAIN;
-- end loop;
-- B := A;
-- while ((ONE - A) - ONE) = ZERO loop
-- A := A * BETA;
-- NEGEP := NEGEP - 1;
-- end loop;
-- NEGEP := -NEGEP;
--
--
-- EPSNEG := A;
-- if (IBETA /= 2) and (IRND /= 0) then
-- A := (A * (ONE + A)) / (ONE + ONE);
-- if ((ONE - A) - ONE) /= ZERO then
-- EPSNEG := A;
-- end if;
-- end if;
--
--
-- MACHEP := -IT - 3;
-- A := B;
-- while ((ONE + A) - ONE) = ZERO loop
-- A := A * BETA;
-- MACHEP := MACHEP + 1;
-- end loop;
--
--
-- EPS := A;
-- if (IBETA /= 2) and (IRND /= 0) then
-- A := (A * (ONE + A)) / (ONE + ONE);
-- if ((ONE + A) - ONE) /= ZERO then
-- EPS := A;
-- end if;
-- end if;
--
--
-- NGRD := 0;
-- if ((IRND = 0) and ((ONE + EPS) * ONE - ONE) /= ZERO) then
-- NGRD := 1;
-- end if;
--
--
-- I := 0;
-- K := 1;
-- Z := BETAIN;
-- loop
-- Y := Z;
-- Z := Y * Y;
-- A := Z * ONE;
-- exit when ((A + A) = ZERO) or (ABS(Z) >= Y);
-- I := I + 1;
-- K := K + K;
-- end loop;
-- if (IBETA /= 10) then
-- IEXP := I + 1;
-- MX := K + K;
-- else
-- IEXP := 2;
-- IZ := IBETA;
-- while (K >= IZ) loop
-- IZ := IZ * IBETA;
-- IEXP := IEXP + 1;
-- end loop;
-- MX := IZ + IZ - 1;
-- end if;
--
-- loop
-- XMIN := Y;
-- Y := Y * BETAIN;
-- A := Y * ONE;
-- exit when ((A + A) = ZERO) or (ABS(Y) >= XMIN);
-- K := K + 1;
-- end loop;
--
--
-- MINEXP := -K;
--
--
-- if ((MX <= (K + K - 3)) and (IBETA /= 10)) then
-- MX := MX + MX;
-- IEXP := IEXP + 1;
-- end if;
--
--
-- MAXEXP := MX + MINEXP;
-- I := MAXEXP + MINEXP;
-- if ((IBETA = 2) and (I = 0)) then
-- MAXEXP := MAXEXP - 1;
-- end if;
-- if (I > 20) then
-- MAXEXP := MAXEXP - 1;
-- end if;
-- if (A /= Y) then
-- MAXEXP := MAXEXP - 2;
-- end if;
--
--
-- XMAX := ONE - EPSNEG;
-- if ((XMAX * ONE) /= XMAX) then
-- XMAX := ONE - BETA * EPSNEG;
-- end if;
-- XMAX := XMAX / (BETA * BETA * BETA * XMIN);
-- I := MAXEXP + MINEXP + 3;
-- if I > 0 then
-- for J in 1..50 loop
-- exit when J > I;
-- if IBETA = 2 then
-- XMAX := XMAX + XMAX;
-- else
-- XMAX := XMAX * BETA;
-- end if;
-- end loop;
-- end if;
--
--PUT("INITIALIZED"); NEW_LINE;
end Floating_Characteristics;
generic
type Element is private;
-- must be a pure value
-- ie. no initialization or finalization is necessary
-- = and := are equality and copy
pragma Must_Be_Constrained (Yes => Element);
package List_Generic is
type List is private;
-- may generate garbage
-- = and := operate on references
-- "make" constructs lists with structural sharing
-- constraint error is raised when nil i provided to any of
-- first, rest, set_first, or set_rest
function Make (X : Element; L : List) return List;
function Nil return List;
function Is_Empty (L : List) return Boolean;
procedure Free (L : in out List);
-- make L empty
function First (L : List) return Element;
function Rest (L : List) return List;
procedure Set_Rest (L : List; To_Be : List);
procedure Set_First (L : List; To_Be : Element);
function Length (L : List) return Natural;
type Iterator is limited private;
procedure Init (Iter : out Iterator; L : List);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Element;
function Done (Iter : Iterator) return Boolean;
private
type Listdata;
type List is access Listdata;
-- variables of type list are initialized to null
type Listdata is
record
First : Element;
Rest : List;
end record;
type Iterator is new List;
end List_Generic;package body List_Generic is
function Nil return List is
begin
return null;
end Nil;
function Is_Empty (L : List) return Boolean is
begin
return L = Nil;
end Is_Empty;
function First (L : List) return Element is
begin
return L.First;
end First;
function Rest (L : List) return List is
begin
return L.Rest;
end Rest;
function Make (X : Element; L : List) return List is
begin
return new Listdata'(X, L);
end Make;
procedure Set_Rest (L : List; To_Be : List) is
begin
L.Rest := To_Be;
end Set_Rest;
procedure Set_First (L : List; To_Be : Element) is
begin
L.First := To_Be;
end Set_First;
procedure Free (L : in out List) is
begin
L := null;
end Free;
function Length (L : List) return Natural is
Count : Natural := 0;
Iter : Iterator;
begin
Init (Iter, L);
while not Done (Iter) loop
Count := Count + 1;
Next (Iter);
end loop;
return Count;
end Length;
procedure Init (Iter : out Iterator; L : List) is
begin
Iter := Iterator (L);
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter := Iterator (Iter.Rest);
end Next;
function Value (Iter : Iterator) return Element is
begin
return Iter.First;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter = null;
end Done;
end List_Generic;package Machine_Independent_Integer32 is
--
-- This package provides integer operations for signed integers that fit
-- comfortable into 32 bits.
-- This spec is "kludged" in that it assumes there is an existing
-- integer or fixed type that will support 32 bit integer operations.
--
-- Current minimal implementation is provided to support the functionality
-- required by the Time_Utilities package.
--
type Integer32 is range Integer'First .. Integer'Last;
function "*" (L : Integer32; R : Integer) return Integer32;
function "/" (L : Integer32; R : Integer) return Integer32;
procedure Div_Rem (L : Integer32;
R : Integer;
Quotient, Remainder : out Integer32);
end Machine_Independent_Integer32;package body Machine_Independent_Integer32 is
function "*" (L : Integer32; R : Integer) return Integer32 is
begin
return L * Integer32 (R);
end "*";
function "/" (L : Integer32; R : Integer) return Integer32 is
begin
return L / Integer32 (R);
end "/";
procedure Div_Rem (L : Integer32;
R : Integer;
Quotient, Remainder : out Integer32) is
Local_Quotient : Integer32 := L / R;
begin
Quotient := Local_Quotient;
Remainder := L - Local_Quotient * R;
end Div_Rem;
end Machine_Independent_Integer32;generic
Size : Integer;
-- number of buckets
type Domain_Type is private;
type Range_Type is private;
-- both types are pure values
-- no initialization or finalization of values of either
-- domain_type or range_type is necessary
-- = and := can be used for equality and copy
with function Hash (Key : Domain_Type) return Integer is <>;
-- efficiency => spread hash over an interval at least as great as size
pragma Must_Be_Constrained (Yes => Domain_Type, Range_Type);
package Map_Generic is
type Map is private;
type Pair is
record
D : Domain_Type;
R : Range_Type;
end record;
function Eval (The_Map : Map; D : Domain_Type) return Range_Type;
procedure Find (The_Map : Map;
D : Domain_Type;
R : in out Range_Type;
Success : out Boolean);
procedure Find (The_Map : Map;
D : Domain_Type;
P : in out Pair;
Success : out Boolean);
procedure Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False);
procedure Undefine (The_Map : in out Map; D : Domain_Type);
procedure Initialize (The_Map : out Map);
function Is_Empty (The_Map : Map) return Boolean;
procedure Make_Empty (The_Map : in out Map);
procedure Copy (Target : in out Map; Source : Map);
type Iterator is limited private;
procedure Init (Iter : out Iterator; The_Map : Map);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Domain_Type;
function Done (Iter : Iterator) return Boolean;
Undefined : exception;
-- raised by eval if the domain value in not in the map
Multiply_Defined : exception;
-- raised by define if the domain value is already defined and
-- the trap_multiples flag has been specified (ie. is true)
function Cardinality (The_Map : Map) return Natural;
function Nil return Map;
function Is_Nil (The_Map : Map) return Boolean;
------------------------------------------------------
-- Implementation Notes and Non-Standard Operations --
------------------------------------------------------
-- := and = operate on references
-- := implies sharing (introduces an alias)
-- = means is the same set, not the same value of type set
-- Initializing a map also makes it empty
-- Accessing an uninitialized map will raise CONSTRAINT_ERROR.
-- garbage may be generated
-- Concurrent Properties
-- any number of find/eval/is_empty may be safely done while one
-- define/undefine is taking place. If the define is redefining
-- an
-- existing element in the domain of the map, concurrrent
-- reading is
-- safe if and only if := on range_type is atomic.
private
type Node;
type Set is access Node;
type Node is
record
Value : Pair;
Link : Set;
end record;
subtype Index is Integer range 0 .. Size - 1;
type Table is array (Index) of Set;
type Map_Data is
record
Bucket : Table;
Size : Integer := 0;
end record;
type Map is access Map_Data;
type Iterator is
record
The_Map : Map;
Index_Value : Index;
Set_Iter : Set;
Done : Boolean;
end record;
end Map_Generic;package body Map_Generic is
function Find (S : Set; D : Domain_Type) return Set is
Rest : Set := S;
begin
while Rest /= null loop
if Rest.Value.D = D then
return Rest;
end if;
Rest := Rest.Link;
end loop;
return null;
end Find;
function Myhash (D : Domain_Type) return Index is
begin
return Index (Hash (D) mod Size);
end Myhash;
function Eval (The_Map : Map; D : Domain_Type) return Range_Type is
Ptr : Set := Find (The_Map.Bucket (Myhash (D)), D);
begin
if Ptr /= null then
return Ptr.Value.R;
else
raise Undefined;
end if;
end Eval;
procedure Find (The_Map : Map;
D : Domain_Type;
R : in out Range_Type;
Success : out Boolean) is
Ptr : Set := Find (The_Map.Bucket (Myhash (D)), D);
begin
if Ptr /= null then
R := Ptr.Value.R;
Success := True;
else
Success := False;
end if;
end Find;
procedure Find (The_Map : Map;
D : Domain_Type;
P : in out Pair;
Success : out Boolean) is
Ptr : Set := Find (The_Map.Bucket (Myhash (D)), D);
begin
if Ptr /= null then
P := Ptr.Value;
Success := True;
else
Success := False;
end if;
end Find;
procedure Define (The_Map : in out Map;
D : Domain_Type;
R : Range_Type;
Trap_Multiples : Boolean := False) is
The_Set : Set renames The_Map.Bucket (Myhash (D));
Ptr : Set := Find (The_Set, D);
Success : Boolean;
begin
if Ptr = null then
The_Set := new Node'(Pair'(D => D, R => R), The_Set);
The_Map.Size := The_Map.Size + 1;
elsif Trap_Multiples then
raise Multiply_Defined;
else
Ptr.Value.R := R;
end if;
end Define;
procedure Undefine (The_Map : in out Map; D : Domain_Type) is
Start : Set renames The_Map.Bucket (Myhash (D));
Current : Set := Start;
Previous : Set := null;
begin
while Current /= null loop
if Current.Value.D = D then
if Previous /= null then
Previous.Link := Current.Link;
else
Start := Current.Link;
end if;
The_Map.Size := The_Map.Size - 1;
return;
else
Previous := Current;
Current := Current.Link;
end if;
end loop;
raise Undefined;
end Undefine;
procedure Copy (Target : in out Map; Source : Map) is
procedure Copy_Set (Target : in out Set; Source : Set) is
Rest : Set := Source;
begin
Target := null;
while Rest /= null loop
Target := new Node'(Rest.Value, Target);
Rest := Rest.Link;
end loop;
end Copy_Set;
begin
for I in Index loop
Copy_Set (Target => Target.Bucket (I), Source => Source.Bucket (I));
end loop;
Target.Size := Source.Size;
end Copy;
procedure Initialize (The_Map : out Map) is
begin
The_Map := new Map_Data;
end Initialize;
function Is_Empty (The_Map : Map) return Boolean is
Iter : Iterator;
begin
for I in Index loop
if The_Map.Bucket (I) /= null then
return False;
end if;
end loop;
return True;
end Is_Empty;
procedure Make_Empty (The_Map : in out Map) is
begin
for I in Index loop
The_Map.Bucket (I) := null;
end loop;
end Make_Empty;
procedure Init (Iter : out Iterator; The_Map : Map) is
The_Iter : Iterator;
begin
for I in Index loop
The_Iter.Set_Iter := The_Map.Bucket (I);
if The_Iter.Set_Iter /= null then
The_Iter.Done := False;
The_Iter.Index_Value := I;
The_Iter.The_Map := The_Map;
Iter := The_Iter;
return;
end if;
end loop;
The_Iter.Done := True;
Iter := The_Iter;
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter.Set_Iter := Iter.Set_Iter.Link;
while Iter.Set_Iter = null loop
if Iter.Index_Value = Index'Last then
Iter.Done := True;
return;
end if;
Iter.Index_Value := Iter.Index_Value + 1;
Iter.Set_Iter := Iter.The_Map.Bucket (Iter.Index_Value);
end loop;
end Next;
function Value (Iter : Iterator) return Domain_Type is
begin
return Iter.Set_Iter.Value.D;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter.Done;
end Done;
function Cardinality (The_Map : Map) return Natural is
begin
return The_Map.Size;
end Cardinality;
function Nil return Map is
begin
return null;
end Nil;
function Is_Nil (The_Map : Map) return Boolean is
begin
return The_Map = null;
end Is_Nil;
end Map_Generic;with Floating_Characteristics;
use Floating_Characteristics;
package Numeric_Io is
Exp_Large : Float;
Exp_Small : Float;
function Sqrt (X : Float) return Float;
function Cbrt (X : Float) return Float;
function Log (X : Float) return Float;
function Log10 (X : Float) return Float;
function Exp (X : Float) return Float;
function "**" (X, Y : Float) return Float;
end Numeric_Io;with Text_Io;
use Text_Io;
with Floating_Characteristics;
use Floating_Characteristics;
--with Numeric_Io;
--use Numeric_Io;
with Numeric_Primitives;
use Numeric_Primitives;
package body Numeric_Io is
-- The following routines are coded directly from the algorithms and
-- coeficients given in "Software Manual for the Elementry Functions"
-- by William J. Cody, Jr. and William Waite, Prentice_Hall, 1980
-- CBRT by analogy
-- A more general formulation uses MANTISSA_TYPE, etc.
-- The coeficients are appropriate for 25 to 32 bits floating significance
-- They will work for less but slightly shorter versions are possible
-- The routines are coded to stand alone so they need not be compiled together
-- These routines have been coded to accept a general MANTISSA_TYPE
-- That is, they are designed to work with a manitssa either fixed of float
-- There are some explicit conversions which are required but these will
-- not cause any extra code to be generated
-- 16 JULY 1982 W A WHITAKER AFATL EGLIN AFB FL 32542
-- T C EICHOLTZ USAFA
function Sqrt (X : Float) return Float is
M, N : Exponent_Type;
F, Y : Mantissa_Type;
Result : Float;
subtype Index is Integer range 0 ..
100; -- #########################
Sqrt_L1 : Index := 3;
-- Could get away with SQRT_L1 := 2 for 28 bits
-- Using the better Cody-Waite coeficients overflows MANTISSA_TYPE
Sqrt_C1 : Mantissa_Type := 8#0.3317777777#;
Sqrt_C2 : Mantissa_Type := 8#0.4460000000#;
Sqrt_C3 : Mantissa_Type := 8#0.55202_36314_77747_36311_0#;
begin
if X = Zero then
Result := Zero;
return Result;
elsif X = One then
-- To get exact SQRT(1.0)
Result := One;
return Result;
elsif X < Zero then
New_Line;
Put ("CALLED SQRT FOR NEGATIVE ARGUMENT ");
raise Program_Error;
--Put (X);
Put (" USED ABSOLUTE VALUE");
New_Line;
Result := Sqrt (abs (X));
return Result;
else
Defloat (X, N, F);
Y := Sqrt_C1 + Mantissa_Type (Sqrt_C2 * F);
for J in 1 .. Sqrt_L1 loop
Y := Y / Mantissa_Divisor_2 + Mantissa_Type
((F / Mantissa_Divisor_2) / Y);
end loop;
if (N mod 2) /= 0 then
Y := Mantissa_Type (Sqrt_C3 * Y);
N := N + 1;
end if;
M := N / 2;
Refloat (M, Y, Result);
return Result;
end if;
exception
when others =>
New_Line;
Put (" EXCEPTION IN SQRT, X = ");
raise Program_Error
--Put (X);
;
Put (" RETURNED 1.0");
New_Line;
return One;
end Sqrt;
function Cbrt (X : Float) return Float is
M, N : Exponent_Type;
F, Y : Mantissa_Type;
Result : Float;
subtype Index is Integer range 0 ..
100; -- #########################
Cbrt_L1 : Index := 3;
Cbrt_C1 : Mantissa_Type := 0.5874009;
Cbrt_C2 : Mantissa_Type := 0.4125990;
Cbrt_C3 : Mantissa_Type := 0.62996_05249;
Cbrt_C4 : Mantissa_Type := 0.79370_05260;
begin
if X = Zero then
Result := Zero;
return Result;
else
Defloat (X, N, F);
F := abs (F);
Y := Cbrt_C1 + Mantissa_Type (Cbrt_C2 * F);
for J in 1 .. Cbrt_L1 loop
Y := Y - (Y / Mantissa_Divisor_3 -
Mantissa_Type ((F / Mantissa_Divisor_3) /
Mantissa_Type (Y * Y)));
end loop;
case (N mod 3) is
when 0 =>
null;
when 1 =>
Y := Mantissa_Type (Cbrt_C3 * Y);
N := N + 2;
when 2 =>
Y := Mantissa_Type (Cbrt_C4 * Y);
N := N + 1;
when others =>
null;
end case;
M := N / 3;
if X < Zero then
Y := -Y;
end if;
Refloat (M, Y, Result);
return Result;
end if;
exception
when others =>
Result := One;
if X < Zero then
Result := -One;
end if;
New_Line;
Put ("EXCEPTION IN CBRT, X = ");
raise Program_Error
--Put (X);
;
Put (" RETURNED ");
raise Program_Error
--Put (Result);
;
New_Line;
return Result;
end Cbrt;
function Log (X : Float) return Float is
-- Uses fixed formulation for generality
Result : Float;
N : Exponent_Type;
Xn : Float;
Y : Float;
F : Mantissa_Type;
Z, Zden, Znum : Mantissa_Type;
C0 : constant Mantissa_Type := 0.20710_67811_86547_52440;
-- SQRT(0.5) - 0.5
C1 : constant Float := 8#0.543#;
C2 : constant Float := -2.12194_44005_46905_82767_9E-4;
function R (Z : Mantissa_Type) return Mantissa_Type is
-- Use fixed formulation here because the float coeficents are > 1.0
-- and would exceed the limits on a MANTISSA_TYPE
A0 : constant Mantissa_Type := 0.04862_85276_587;
B0 : constant Mantissa_Type := 0.69735_92187_803;
B1 : constant Mantissa_Type := -0.125;
C : constant Mantissa_Type := 0.01360_09546_862;
begin
return Z + Mantissa_Type
(Z * Mantissa_Type
(Mantissa_Type (Z * Z) *
(C + Mantissa_Type
(A0 / (B0 +
Mantissa_Type
(B1 * Mantissa_Type
(Z * Z)))))));
end R;
begin
if X < Zero then
New_Line;
Put ("CALLED LOG FOR NEGATIVE ");
raise Program_Error
--Put (X);
;
Put (" USE ABS => ");
Result := Log (abs (X));
raise Program_Error
--Put (Result);
;
New_Line;
elsif X = Zero then
New_Line;
Put ("CALLED LOG FOR ZERO ARGUMENT, RETURNED ");
Result := -Xmax; -- SUPPOSED TO BE -LARGE
raise Program_Error
--Put (Result);
;
New_Line;
else
Defloat (X, N, F);
Znum := F - Mantissa_Half;
Y := Convert_To_Float (Znum);
Zden := Znum / Mantissa_Divisor_2 + Mantissa_Half;
if Znum > C0 then
Y := Y - Mantissa_Half;
Znum := Znum - Mantissa_Half;
Zden := Zden + Mantissa_Half / Mantissa_Divisor_2;
else
N := N - 1;
end if;
Z := Mantissa_Type (Znum / Zden);
Result := Convert_To_Float (R (Z));
if N /= 0 then
Xn := Convert_To_Float (N);
Result := (Xn * C2 + Result) + Xn * C1;
end if;
end if;
return Result;
exception
when others =>
New_Line;
Put (" EXCEPTION IN LOG, X = ");
raise Program_Error;
--Put (X);
Put (" RETURNED 0.0");
New_Line;
return Zero;
end Log;
function Log10 (X : Float) return Float is
Log_10_Of_2 : constant Float :=
Convert_To_Float (Mantissa_Type (
8#0.33626_75425_11562_41615#));
begin
return Log (X) * Log_10_Of_2;
end Log10;
function Exp (X : Float) return Float is
Result : Float;
N : Exponent_Type;
Xg, Xn, X1, X2 : Float;
F, G : Mantissa_Type;
Bigx : Float := Exp_Large;
Smallx : Float := Exp_Small;
One_Over_Log_2 : constant Float := 1.4426_95040_88896_34074;
C1 : constant Float := 0.69335_9375;
C2 : constant Float := -2.1219_44400_54690_58277E-4;
function R (G : Mantissa_Type) return Mantissa_Type is
Z, Gp, Q : Mantissa_Type;
P0 : constant Mantissa_Type := 0.24999_99999_9992;
P1 : constant Mantissa_Type := 0.00595_04254_9776;
Q0 : constant Mantissa_Type := 0.5;
Q1 : constant Mantissa_Type := 0.05356_75176_4522;
Q2 : constant Mantissa_Type := 0.00029_72936_3682;
begin
Z := Mantissa_Type (G * G);
Gp := Mantissa_Type ((Mantissa_Type (P1 * Z) + P0) * G);
Q := Mantissa_Type ((Mantissa_Type (Q2 * Z) + Q1) * Z) + Q0;
return Mantissa_Half + Mantissa_Type (Gp / (Q - Gp));
end R;
begin
if X > Bigx then
New_Line;
Put (" EXP CALLED WITH TOO BIG A POSITIVE ARGUMENT, ");
raise Program_Error
--Put (X);
;
Put (" RETURNED XMAX");
New_Line;
Result := Xmax;
elsif X < Smallx then
New_Line;
Put (" EXP CALLED WITH TOO BIG A NEGATIVE ARGUMENT, ");
raise Program_Error;
--Put (X);
Put (" RETURNED ZERO");
New_Line;
Result := Zero;
elsif abs (X) < Eps then
Result := One;
else
N := Exponent_Type (X * One_Over_Log_2);
Xn := Convert_To_Float (N);
X1 := Round (X);
X2 := X - X1;
Xg := ((X1 - Xn * C1) + X2) - Xn * C2;
G := Mantissa_Type (Xg);
N := N + 1;
F := R (G);
Refloat (N, F, Result);
end if;
return Result;
exception
when others =>
New_Line;
Put (" EXCEPTION IN EXP, X = ");
raise Program_Error;
--Put (X);
Put (" RETURNED 1.0");
New_Line;
return One;
end Exp;
function "**" (X, Y : Float) return Float is
-- This is the last function to be coded since it appeared that it really
-- was un-Ada-like and ought not be in the regular package
-- Nevertheless it was included in this version
-- It is specific for FLOAT and does not have the MANTISSA_TYPE generality
M, N : Exponent_Type;
G : Mantissa_Type;
P, Temp, Iw1, I : Integer;
Result, Z, V, R, U1, U2, W, W1, W2, W3, Y1, Y2 : Float;
K : constant Float := 0.44269_50408_88963_40736;
Ibigx : constant Integer := Integer
(Truncate (16.0 * Log (Xmax) - 1.0));
Ismallx : constant Integer := Integer
(Truncate (16.0 * Log (Xmin) + 1.0));
P1 : constant Float := 0.83333_32862_45E-1;
P2 : constant Float := 0.12506_48500_52E-1;
Q1 : constant Float := 0.69314_71805_56341;
Q2 : constant Float := 0.24022_65061_44710;
Q3 : constant Float := 0.55504_04881_30765E-1;
Q4 : constant Float := 0.96162_06595_83789E-2;
Q5 : constant Float := 0.13052_55159_42810E-2;
A1 : array (1 .. 17) of Float :=
(8#1.00000_0000#, 8#0.75222_5750#, 8#0.72540_3067#, 8#0.70146_3367#,
8#0.65642_3746#, 8#0.63422_2140#, 8#0.61263_4520#, 8#0.57204_2434#,
8#0.55202_3631#, 8#0.53254_0767#, 8#0.51377_3265#,
8#0.47572_4623#, 8#0.46033_7602#, 8#0.44341_7233#,
8#0.42712_7017#, 8#0.41325_3033#, 8#0.40000_0000#);
A2 : array (1 .. 8) of Float :=
(8#0.00000_00005_22220_66302_61734_72062#,
8#0.00000_00003_02522_47021_04062_61124#,
8#0.00000_00005_21760_44016_17421_53016#,
8#0.00000_00007_65401_41553_72504_02177#,
8#0.00000_00002_44124_12254_31114_01243#,
8#0.00000_00000_11064_10432_66404_42174#,
8#0.00000_00004_72542_16063_30176_55544#,
8#0.00000_00001_74611_03661_23056_22556#);
function Reduce (V : Float) return Float is
begin
return Float (Integer (16.0 * V)) * 0.0625;
end Reduce;
begin
if X <= Zero then
if X < Zero then
Result := (abs (X)) ** Y;
New_Line;
Put ("X**Y CALLED WITH X = ");
raise Program_Error;
--Put (X);
New_Line;
Put ("USED ABS, RETURNED ");
raise Program_Error
--Put (Result);
;
New_Line;
else
if Y <= Zero then
if Y = Zero then
Result := Zero;
else
Result := Xmax;
end if;
New_Line;
Put ("X**Y CALLED WITH X = 0, Y = ");
raise Program_Error;
--Put (Y);
New_Line;
Put ("RETURNED ");
raise Program_Error
--Put (Result);
;
New_Line;
else
Result := Zero;
end if;
end if;
else
Defloat (X, M, G);
P := 1;
if G <= A1 (9) then
P := 9;
end if;
if G <= A1 (P + 4) then
P := P + 4;
end if;
if G <= A1 (P + 2) then
P := P + 2;
end if;
Z := ((G - A1 (P + 1)) - A2 ((P + 1) / 2)) / (G + A1 (P + 1));
Z := Z + Z;
V := Z * Z;
R := (P2 * V + P1) * V * Z;
R := R + K * R;
U2 := (R + Z * K) + Z;
U1 := Float (Integer (M) * 16 - P) * 0.0625;
Y1 := Reduce (Y);
Y2 := Y - Y1;
W := U2 * Y + U1 * Y2;
W1 := Reduce (W);
W2 := W - W1;
W := W1 + U1 * Y1;
W1 := Reduce (W);
W2 := W2 + (W - W1);
W3 := Reduce (W2);
Iw1 := Integer (Truncate (16.0 * (W1 + W3)));
W2 := W2 - W3;
if W > Float (Ibigx) then
Result := Xmax;
Put ("X**Y CALLED X =");
raise Program_Error;
--Put (X);
Put (" Y =");
raise Program_Error
--Put (Y);
;
Put (" TOO LARGE RETURNED ");
raise Program_Error;
--Put (Result);
New_Line;
elsif W < Float (Ismallx) then
Result := Zero;
Put ("X**Y CALLED X =");
raise Program_Error;
--Put (X);
Put (" Y =");
raise Program_Error
--Put (Y);
;
Put (" TOO SMALL RETURNED ");
raise Program_Error
--Put (Result);
;
New_Line;
else
if W2 > Zero then
W2 := W2 - 0.0625;
Iw1 := Iw1 + 1;
end if;
if Iw1 < Integer (Zero) then
I := 0;
else
I := 1;
end if;
M := Exponent_Type (I + Iw1 / 16);
P := 16 * Integer (M) - Iw1;
Z := ((((Q5 * W2 + Q4) * W2 + Q3) * W2 + Q2) * W2 + Q1) * W2;
Z := A1 (P + 1) + (A1 (P + 1) * Z);
Refloat (M, Z, Result);
end if;
end if;
return Result;
end "**";
begin
Exp_Large := Log (Xmax) * (One - Eps);
Exp_Small := Log (Xmin) * (One - Eps);
end Numeric_Io;
with Floating_Characteristics;
use Floating_Characteristics;
package Numeric_Primitives is
-- This may seem a little much but is put in this form to allow the
-- same form to be used for a generic package
-- If that is not needed, simple litterals could be substituted
Zero : Float := Convert_To_Float (Integer (0));
One : Float := Convert_To_Float (Integer (1));
Two : Float := One + One;
Three : Float := One + One + One;
Half : Float := One / Two;
-- The following "constants" are effectively deferred to
-- the initialization part of the package body
-- This is in order to make it possible to generalize the floating type
-- If that capability is not desired, constants may be included here
Pi : Float;
One_Over_Pi : Float;
Two_Over_Pi : Float;
Pi_Over_Two : Float;
Pi_Over_Three : Float;
Pi_Over_Four : Float;
Pi_Over_Six : Float;
function Sign (X, Y : Float) return Float;
-- Returns the value of X with the sign of Y
function Max (X, Y : Float) return Float;
-- Returns the algebraicly larger of X and Y
function Min (X, Y : Float) return Float;
-- Returns the algebraicly smaller of X and Y
function Truncate (X : Float) return Float;
-- Returns the floating value of the integer no larger than X
-- AINT(X)
function Round (X : Float) return Float;
-- Returns the floating value nearest X
-- AINTRND(X)
function Ran return Float;
-- This uses a portable algorithm and is included at this point
-- Algorithms that presume unique machine hardware information
-- should be initiated in FLOATING_CHARACTERISTICS
end Numeric_Primitives;with Floating_Characteristics;
use Floating_Characteristics;
package body Numeric_Primitives is
function Sign (X, Y : Float) return Float is
-- Returns the value of X with the sign of Y
begin
if Y >= 0.0 then
return X;
else
return -X;
end if;
end Sign;
function Max (X, Y : Float) return Float is
begin
if X >= Y then
return X;
else
return Y;
end if;
end Max;
function Min (X, Y : Float) return Float is
begin
if X <= Y then
return X;
else
return Y;
end if;
end Min;
function Truncate (X : Float) return Float is
-- Optimum code depends on how the system rounds at exact halves
begin
if Float (Integer (X)) = X then
return X;
end if;
if X > Zero then
return Float (Integer (X - Half));
elsif X = Zero then
return Zero;
else
return Float (Integer (X + Half));
end if;
end Truncate;
function Round (X : Float) return Float is
begin
return Float (Integer (X));
end Round;
package Key is
X : Integer := 10_001;
Y : Integer := 20_001;
Z : Integer := 30_001;
end Key;
function Ran return Float is
-- This rectangular random number routine is adapted from a report
-- "A Pseudo-Random Number Generator" by B. A. Wichmann and I. D. Hill
-- NPL Report DNACS XX (to be published)
-- In this stripped version, it is suitable for machines supporting
-- INTEGER at only 16 bits and is portable in Ada
W : Float;
begin
Key.X := 171 * (Key.X mod 177 - 177) - 2 * (Key.X / 177);
if Key.X < 0 then
Key.X := Key.X + 30269;
end if;
Key.Y := 172 * (Key.Y mod 176 - 176) - 35 * (Key.Y / 176);
if Key.Y < 0 then
Key.Y := Key.Y + 30307;
end if;
Key.Z := 170 * (Key.Z mod 178 - 178) - 63 * (Key.Z / 178);
if Key.Z < 0 then
Key.Z := Key.Z + 30323;
end if;
-- CONVERT_TO_FLOAT is used instead of FLOAT since the floating
-- type may be software defined
W := Convert_To_Float (Key.X) / 30269.0 +
Convert_To_Float (Key.Y) / 30307.0 +
Convert_To_Float (Key.Z) / 30323.0;
return W - Convert_To_Float (Integer (W - 0.5));
end Ran;
begin
Pi := Convert_To_Float (Integer (3)) +
Convert_To_Float (Mantissa_Type (0.14159_26535_89793_23846));
One_Over_Pi := Convert_To_Float (Mantissa_Type (0.31830_98861_83790_67154));
Two_Over_Pi := Convert_To_Float (Mantissa_Type (0.63661_97723_67581_34308));
Pi_Over_Two := Convert_To_Float (Integer (1)) +
Convert_To_Float
(Mantissa_Type (
0.57079_63267_94896_61923));
Pi_Over_Three := Convert_To_Float (Integer (1)) +
Convert_To_Float (Mantissa_Type
(0.04719_75511_96597_74615));
Pi_Over_Four := Convert_To_Float
(Mantissa_Type (0.78539_81633_97448_30962));
Pi_Over_Six := Convert_To_Float (Mantissa_Type (0.52359_87755_98298_87308));
end Numeric_Primitives;
generic
type Element is private;
pragma Must_Be_Constrained (Yes => Element);
package Queue_Generic is
type Queue is private;
procedure Initialize (Q : out Queue);
function Is_Empty (Q : Queue) return Boolean;
procedure Make_Empty (Q : in out Queue);
procedure Copy (Target : in out Queue; Source : Queue);
procedure Add (Q : in out Queue; X : Element);
procedure Delete (Q : in out Queue);
function First (Q : Queue) return Element;
-- on calls to delete and first, not is_empty(q) is assumed
-- constraint error will be raises is is_empty(q)
type Iterator is limited private;
procedure Init (Iter : out Iterator; Q : Queue);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Element;
function Done (Iter : Iterator) return Boolean;
------------------------------------------------------
-- Implementation Notes and Non-Standard Operations --
------------------------------------------------------
-- variables of type queue are initially empty
-- therefore, the call to initialize is optional
-- := and = are meaningless
-- := implies sharing (introduces an alias) for sub-structures
-- garbage may be generated
private
type Node;
type Pointer is access Node;
type Node is
record
Value : Element;
Link : Pointer;
end record;
type Queue is
record
Head : Pointer;
Tail : Pointer;
end record;
type Iterator is new Queue;
end Queue_Generic;package body Queue_Generic is
procedure Initialize (Q : out Queue) is
begin
null;
end Initialize;
function Is_Empty (Q : Queue) return Boolean is
begin
return Q.Head = null;
end Is_Empty;
procedure Make_Empty (Q : in out Queue) is
begin
Q.Head := null;
Q.Tail := null;
end Make_Empty;
procedure Init (Iter : out Iterator; Q : Queue) is
begin
Iter := Iterator (Q);
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter.Head := Iter.Head.Link;
end Next;
function Value (Iter : Iterator) return Element is
begin
return Iter.Head.Value;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter.Head = null;
end Done;
procedure Copy (Target : in out Queue; Source : Queue) is
Iter : Iterator;
begin
Make_Empty (Target);
Init (Iter, Source);
while not Done (Iter) loop
Add (Target, Value (Iter));
Next (Iter);
end loop;
end Copy;
procedure Add (Q : in out Queue; X : Element) is
New_Node : constant Pointer := new Node'(X, null);
begin
if Q.Head = null then
Q.Head := New_Node;
else
Q.Tail.Link := New_Node;
end if;
Q.Tail := New_Node;
end Add;
procedure Delete (Q : in out Queue) is
First : constant Pointer := Q.Head;
begin
Q.Head := First.Link;
First.Link := null;
if Q.Head = null then
Q.Tail := null;
end if;
end Delete;
function First (Q : Queue) return Element is
begin
return Q.Head.Value;
end First;
end Queue_Generic;generic
type Element is private;
-- must be a pure value
-- ie. no initialization or finalization is necessary
-- = and := are equality and copy
pragma Must_Be_Constrained (Yes => Element);
package Set_Generic is
type Set is private;
procedure Initialize (S : out Set);
function Is_Empty (S : Set) return Boolean;
procedure Make_Empty (S : in out Set);
procedure Copy (Target : in out Set; Source : Set);
function Is_Member (S : Set; X : Element) return Boolean;
procedure Add (S : in out Set; X : Element);
procedure Delete (S : in out Set; X : Element);
-- X is (is not) in S then the operation add (delete) is a no op.
type Iterator is limited private;
procedure Init (Iter : out Iterator; S : Set);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Element;
function Done (Iter : Iterator) return Boolean;
------------------------------------------------------
-- Implementation Notes and Non-Standard Operations --
------------------------------------------------------
-- variables of type set are initially empty
-- therefore, the call to initialize is optional
-- initialize does make the set empty
-- := and = operate on references
-- := implies sharing (introduces an alias)
-- = means is the same set, not the same value of type set
-- garbage may be generated
-- Concurrency Properties
-- any number of read operations (is_empty,is_member) can procede
-- concurrently with one write operations (add/delete/make_empty)
private
type Node is
record
Value : Element;
Link : Set;
end record;
type Set is access Node;
type Iterator is new Set;
end Set_Generic;package body Set_Generic is
procedure Initialize (S : out Set) is
begin
S := null;
end Initialize;
function Is_Empty (S : Set) return Boolean is
begin
return S = null;
end Is_Empty;
procedure Make_Empty (S : in out Set) is
begin
S := null;
end Make_Empty;
procedure Init (Iter : out Iterator; S : Set) is
begin
Iter := Iterator (S);
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter := Iterator (Iter.Link);
end Next;
function Value (Iter : Iterator) return Element is
begin
return Iter.Value;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter = null;
end Done;
procedure Copy (Target : in out Set; Source : Set) is
Rest : Set := Source;
begin
Target := null;
while Rest /= null loop
Target := new Node'(Rest.Value, Target);
Rest := Rest.Link;
end loop;
end Copy;
function Is_Member (S : Set; X : Element) return Boolean is
Rest : Set := S;
begin
while Rest /= null loop
if Rest.Value = X then
return True;
end if;
Rest := Rest.Link;
end loop;
return False;
end Is_Member;
procedure Add (S : in out Set; X : Element) is
begin
if not Is_Member (S, X) then
S := new Node'(X, S);
end if;
end Add;
procedure Delete (S : in out Set; X : Element) is
Current : Set := S;
Previous : Set := null;
begin
while Current /= null loop
if Current.Value = X then
if Previous /= null then
Previous.Link := Current.Link;
else
S := Current.Link;
end if;
return;
end if;
Previous := Current;
Current := Current.Link;
end loop;
end Delete;
end Set_Generic;generic
type Element is private;
pragma Must_Be_Constrained (Yes => Element);
package Stack_Generic is
type Stack is private;
Empty_Stack : constant Stack;
-- It is expected that a declared stack is initialized to Empty_Stack
procedure Make_Empty (S : in out Stack);
procedure Pop (S : in out Stack);
procedure Push (X : Element; S : in out Stack);
function Empty (S : Stack) return Boolean;
function Top (S : Stack) return Element;
procedure Copy (Target : in out Stack; Source : Stack);
Underflow : exception;
type Iterator is private;
procedure Init (Iter : out Iterator; S : Stack);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Element;
function Done (Iter : Iterator) return Boolean;
private
type Stack_Node;
type Stack is access Stack_Node;
Empty_Stack : constant Stack := null;
type Iterator is new Stack;
end Stack_Generic;package body Stack_Generic is
type Stack_Node is
record
Elt : Element;
Link : Stack;
end record;
procedure Make_Empty (S : in out Stack) is
begin
S := null;
end Make_Empty;
procedure Pop (S : in out Stack) is
begin
if S = null then
raise Underflow;
else
S := S.Link;
end if;
end Pop;
procedure Push (X : Element; S : in out Stack) is
New_Node : Stack;
begin
New_Node := new Stack_Node'(Elt => X, Link => S);
S := New_Node;
end Push;
function Empty (S : Stack) return Boolean is
begin
return S = null;
end Empty;
function Top (S : Stack) return Element is
begin
if S = null then
raise Underflow;
else
return S.Elt;
end if;
end Top;
procedure Copy (Target : in out Stack; Source : Stack) is
Rest_Of_Source : Stack;
Last_Of_Target : Stack;
begin
if Source /= null then
Target := new Stack_Node'(Elt => Source.Elt, Link => null);
Last_Of_Target := Target;
Rest_Of_Source := Source.Link;
while Rest_Of_Source /= null loop
Last_Of_Target.Link :=
new Stack_Node'(Elt => Rest_Of_Source.Elt, Link => null);
Last_Of_Target := Last_Of_Target.Link;
Rest_Of_Source := Rest_Of_Source.Link;
end loop;
else
Target := null;
end if;
end Copy;
procedure Init (Iter : out Iterator; S : Stack) is
begin
Iter := Iterator (S);
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter := Iterator (Iter.Link);
end Next;
function Value (Iter : Iterator) return Element is
begin
return Iter.Elt;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter = null;
end Done;
end Stack_Generic;generic
Size : Integer;
type Range_Type is private;
-- Range_Type is a pure value
-- no initialization or finalization of values of range_type is
-- necessary
-- = and := can be used for equality and copy
Ignore_Case : Boolean := True;
pragma Must_Be_Constrained (Yes => Range_Type);
package String_Map_Generic is
type Map is private;
function Eval (The_Map : Map; D : String) return Range_Type;
procedure Find (The_Map : Map;
D : String;
R : in out Range_Type;
Success : out Boolean);
procedure Define (The_Map : in out Map;
D : String;
R : Range_Type;
Trap_Multiples : Boolean := False);
procedure Undefine (The_Map : in out Map; D : String);
procedure Initialize (The_Map : out Map);
function Is_Empty (The_Map : Map) return Boolean;
procedure Make_Empty (The_Map : in out Map);
procedure Copy (Target : in out Map; Source : Map);
type Iterator is private;
procedure Init (Iter : out Iterator; The_Map : Map);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return String;
function Done (Iter : Iterator) return Boolean;
Undefined : exception;
-- raised by eval if the domain value in not in the map
Multiply_Defined : exception;
-- raised by define if the domain value is already defined and
-- the trap_multiples flag has been specified (ie. is true)
function Nil return Map;
function Is_Nil (The_Map : Map) return Boolean;
function Cardinality (The_Map : Map) return Natural;
------------------------------------------------------
-- Implementation Notes and Non-Standard Operations --
------------------------------------------------------
-- := and = operate on references
-- := implies sharing (introduces an alias)
-- = means is the same set, not the same value of type set
-- Initializing a map also makes it empty
-- Accessing an uninitialized map will raise CONSTRAINT_ERROR.
-- garbage may be generated
private
subtype Index is Natural range 0 .. Size - 1;
type Node (Size : Natural);
type Set is access Node;
type Table is array (Index) of Set;
type Map_Data is
record
Bucket : Table;
Size : Integer := 0;
end record;
type Map is access Map_Data;
type Iterator is
record
The_Map : Map;
Index_Value : Index;
Set_Iter : Set;
Done : Boolean;
end record;
type Node (Size : Natural) is
record
Link : Set;
Value : Range_Type;
Name : String (1 .. Size);
end record;
end String_Map_Generic;with String_Utilities;
package body String_Map_Generic is
function Find (S : Set; Name : String) return Set is
Rest : Set := S;
begin
if Ignore_Case then
declare
Upper_Name : constant String :=
String_Utilities.Upper_Case (Name);
begin
while Rest /= null loop
if Rest.Name'Length = Upper_Name'Length and then
String_Utilities.Upper_Case (Rest.Name) = Upper_Name then
return Rest;
end if;
Rest := Rest.Link;
end loop;
end;
else
while Rest /= null loop
if Rest.Name = Name then
return Rest;
end if;
Rest := Rest.Link;
end loop;
end if;
return null;
end Find;
function Hash (Name : String) return Index is
begin
return Index'(String_Utilities.Hash_String (Name) mod Size);
end Hash;
pragma Inline (Hash);
function Eval (The_Map : Map; D : String) return Range_Type is
Ptr : Set := Find (The_Map.Bucket (Hash (D)), D);
begin
if Ptr /= null then
return Ptr.Value;
else
raise Undefined;
end if;
end Eval;
procedure Find (The_Map : Map;
D : String;
R : in out Range_Type;
Success : out Boolean) is
Ptr : Set := Find (The_Map.Bucket (Hash (D)), D);
begin
if Ptr /= null then
R := Ptr.Value;
Success := True;
else
Success := False;
end if;
end Find;
procedure Define (The_Map : in out Map;
D : String;
R : Range_Type;
Trap_Multiples : Boolean := False) is
This_Node : Set renames The_Map.Bucket (Hash (D));
The_Set : Set := This_Node;
Ptr : Set := Find (The_Set, D);
begin
if Ptr = null then
This_Node := new Node (D'Length);
declare
N : Node renames This_Node.all;
begin
N.Link := The_Set;
N.Value := R;
N.Name := D;
end;
The_Map.Size := The_Map.Size + 1;
elsif Trap_Multiples then
raise Multiply_Defined;
else
Ptr.Value := R;
end if;
end Define;
procedure Undefine (The_Map : in out Map; D : String) is
The_Bucket : Index := Hash (D);
Current : Set := The_Map.Bucket (The_Bucket);
Previous : Set := null;
begin
while Current /= null loop
if Current.Name = D then
if Previous /= null then
Previous.Link := Current.Link;
else
The_Map.Bucket (The_Bucket) := Current.Link;
end if;
The_Map.Size := The_Map.Size - 1;
return;
else
Previous := Current;
Current := Current.Link;
end if;
end loop;
raise Undefined;
end Undefine;
procedure Copy (Target : in out Map; Source : Map) is
Rest : Set;
begin
for I in Index loop
Rest := Source.Bucket (I);
Target.Bucket (I) := null;
while Rest /= null loop
Target.Bucket (I) := new Node'(Size => Rest.Name'Length,
Name => Rest.Name,
Value => Rest.Value,
Link => Target.Bucket (I));
Rest := Rest.Link;
end loop;
end loop;
Target.Size := Source.Size;
end Copy;
procedure Initialize (The_Map : out Map) is
begin
The_Map := new Map_Data;
end Initialize;
function Is_Empty (The_Map : Map) return Boolean is
Iter : Iterator;
begin
for I in Index loop
if The_Map.Bucket (I) /= null then
return False;
end if;
end loop;
return True;
end Is_Empty;
procedure Make_Empty (The_Map : in out Map) is
begin
for I in Index loop
The_Map.Bucket (I) := null;
end loop;
end Make_Empty;
procedure Init (Iter : out Iterator; The_Map : Map) is
The_Iter : Iterator;
begin
for I in Index loop
The_Iter.Set_Iter := The_Map.Bucket (I);
if The_Iter.Set_Iter /= null then
The_Iter.Done := False;
The_Iter.Index_Value := I;
The_Iter.The_Map := The_Map;
Iter := The_Iter;
return;
end if;
end loop;
The_Iter.Done := True;
Iter := The_Iter;
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter.Set_Iter := Iter.Set_Iter.Link;
while Iter.Set_Iter = null loop
if Iter.Index_Value = Index'Last then
Iter.Done := True;
return;
end if;
Iter.Index_Value := Iter.Index_Value + 1;
Iter.Set_Iter := Iter.The_Map.Bucket (Iter.Index_Value);
end loop;
end Next;
function Value (Iter : Iterator) return String is
begin
return Iter.Set_Iter.Name;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter.Done;
end Done;
function Nil return Map is
begin
return null;
end Nil;
function Is_Nil (The_Map : Map) return Boolean is
begin
return The_Map = null;
end Is_Nil;
function Cardinality (The_Map : Map) return Natural is
begin
return The_Map.Size;
end Cardinality;
end String_Map_Generic;package String_Table is
type Item is private;
type Table is private;
Table_Full : exception;
-- create a table for unique strings
function New_Table (Minimum_Table_Size : Natural := 127) return Table;
function Nil return Item;
-- return unique item in table, ignore_case => upper_case storage
function Unique (Source : String;
In_Table : Table;
Ignore_Case : Boolean := True) return Item;
-- return item if present, otherwise Nil
function Find (Source : String;
In_Table : Table;
Ignore_Case : Boolean := True) return Item;
-- return an item without entering in table
function Allocate (Source : String; In_Table : Table) return Item;
-- compare strings for identity, then same contents
function Equal (L, R : Item) return Boolean;
-- representation of string, suitable for hashing
function Unique_Index (U : Item) return Integer;
-- value of character or entire string
function Char_At (Source : Item; At_Pos : Natural) return Character;
function Image (Source : Item) return String;
function Length (Source : Item) return Natural;
function Is_Nil (Source : Item) return Boolean;
type Iterator is private;
procedure Init (Iter : out Iterator; The_Table : Table);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Item;
function Done (Iter : Iterator) return Boolean;
private
type Table_Storage;
type Table is access Table_Storage;
type Item is access String;
type Sym_Rec;
type Long_Sym_Pointer is access Sym_Rec;
type Sym_Pointer is new Long_Sym_Pointer;
subtype Element_Index is Integer;
type Iterator is
record
The_Table : Table;
Bucket : Element_Index;
Member : Long_Sym_Pointer;
end record;
end String_Table;with String_Utilities;
with Unchecked_Conversion;
package body String_Table is
function Item_To_Integer is new Unchecked_Conversion (Item, Integer);
package Util renames String_Utilities;
type Sym_Rec is
record
Value : Item;
Next : Sym_Pointer;
end record;
type Table_Storage is array (Element_Index range <>) of Sym_Pointer;
function Nil return Item is
begin
return null;
end Nil;
function Hash_Code (S : String; Hash_Size : Positive)
return Element_Index is
begin
return Element_Index (abs (Util.Hash_String (S) mod Hash_Size));
end Hash_Code;
pragma Inline (Hash_Code);
function New_Table (Minimum_Table_Size : Natural := 127) return Table is
begin
return new Table_Storage (0 .. Minimum_Table_Size);
end New_Table;
function Unique (Source : String;
In_Table : Table;
Ignore_Case : Boolean := True) return Item is
Bucket : Sym_Pointer renames In_Table
(Hash_Code (Source, In_Table'Length));
Chain : Sym_Pointer := Bucket;
begin
if Source'Length = 0 then
return null;
end if;
if Ignore_Case then
declare
S : constant String := Util.Upper_Case (Source);
begin
while Chain /= null loop
if Util.Upper_Case (Chain.Value.all) = S then
return Chain.Value;
end if;
Chain := Chain.Next;
end loop;
end;
else
while Chain /= null loop
if Chain.Value.all = Source then
return Chain.Value;
end if;
Chain := Chain.Next;
end loop;
end if;
Chain := new Sym_Rec;
Chain.Value := new String'(Source);
Chain.Next := Bucket;
Bucket := Chain;
return Chain.Value;
end Unique;
function Find (Source : String;
In_Table : Table;
Ignore_Case : Boolean := True) return Item is
Chain : Sym_Pointer := In_Table (Hash_Code (Source, In_Table'Length));
begin
if Source'Length = 0 then
return null;
end if;
if Ignore_Case then
declare
S : constant String := Util.Upper_Case (Source);
begin
while Chain /= null loop
if Util.Upper_Case (Chain.Value.all) = S then
return Chain.Value;
end if;
Chain := Chain.Next;
end loop;
end;
else
while Chain /= null loop
if Chain.Value.all = Source then
return Chain.Value;
end if;
Chain := Chain.Next;
end loop;
end if;
return null;
end Find;
function Allocate (Source : String; In_Table : Table) return Item is
begin
if Source'Length > 0 then
return new String'(Source);
else
return Nil;
end if;
end Allocate;
function Equal (L, R : Item) return Boolean is
begin
return L = R or else
((L /= Nil and then R /= Nil) and then L.all = R.all);
end Equal;
function Unique_Index (U : Item) return Integer is
begin
return Item_To_Integer (U);
end Unique_Index;
function Char_At (Source : Item; At_Pos : Natural) return Character is
begin
return Source (At_Pos - 1 + Source'First);
end Char_At;
function Image (Source : Item) return String is
begin
if Source = Nil then
return "";
else
return Source.all;
end if;
end Image;
function Length (Source : Item) return Natural is
begin
if Source = Nil then
return 0;
else
return Source.all'Length;
end if;
end Length;
function Is_Nil (Source : Item) return Boolean is
begin
return Source = Nil;
end Is_Nil;
procedure Incr (Iter : in out Iterator) is
begin
loop
Iter.Member := Long_Sym_Pointer (Iter.The_Table (Iter.Bucket));
exit when Iter.Member /= null or else
Iter.Bucket = Iter.The_Table'Last;
Iter.Bucket := Iter.Bucket + 1;
end loop;
end Incr;
procedure Init (Iter : out Iterator; The_Table : Table) is
The_Iter : Iterator;
begin
The_Iter.The_Table := The_Table;
The_Iter.Bucket := 0;
Incr (The_Iter);
Iter := The_Iter;
end Init;
procedure Next (Iter : in out Iterator) is
begin
Iter.Member := Long_Sym_Pointer (Iter.Member.Next);
if Iter.Member = null and then Iter.Bucket /= Iter.The_Table'Last then
Iter.Bucket := Iter.Bucket + 1;
Incr (Iter);
end if;
end Next;
function Value (Iter : Iterator) return Item is
begin
return Iter.Member.Value;
end Value;
function Done (Iter : Iterator) return Boolean is
begin
return Iter.Member = null;
end Done;
end String_Table;package String_Utilities is
function Hash_String (S : String) return Integer;
procedure Upper_Case (C : in out Character);
procedure Lower_Case (C : in out Character);
function Upper_Case (C : Character) return Character;
function Lower_Case (C : Character) return Character;
procedure Upper_Case (S : in out String);
procedure Lower_Case (S : in out String);
-- string returned has same 'First and 'Last as S
function Upper_Case (S : String) return String;
function Lower_Case (S : String) return String;
function Number_To_String (Value : Integer;
Base : Natural := 10;
Width : Natural := 0;
Leading : Character := ' ') return String;
-- function Number_To_String (Value : Long_Integer;
-- Base : Natural := 10;
-- Width : Natural := 0;
-- Leading : Character := ' ') return String;
procedure String_To_Number (Source : String;
Target : out Integer;
Worked : out Boolean;
Base : Natural := 10);
-- procedure String_To_Number (Source : String;
-- Target : out Long_Integer;
-- Worked : out Boolean;
-- Base : Natural := 10);
function Strip_Leading
(From : String; Filler : Character := ' ') return String;
function Strip_Trailing
(From : String; Filler : Character := ' ') return String;
function Strip (From : String; Filler : Character := ' ') return String;
-- Searches and compares
-- Locate returns the index value in Within if found, 0 otherwise
function Locate (Fragment : String;
Within : String;
Ignore_Case : Boolean := False) return Natural;
function Locate (Fragment : Character;
Within : String;
Ignore_Case : Boolean := False) return Natural;
function Reverse_Locate (Fragment : String;
Within : String;
Ignore_Case : Boolean := False) return Natural;
function Reverse_Locate (Fragment : Character;
Within : String;
Ignore_Case : Boolean := False) return Natural;
function Equal
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean;
function Less_Than
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean;
function Greater_Than
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean;
procedure Capitalize (S : in out String);
function Capitalize (S : String) return String;
end String_Utilities;with Bounded_String;
package body String_Utilities is
type Translate_Table is array (Character) of Character;
type Equality_Table is array (Character, Character) of Boolean;
pragma Pack (Equality_Table);
Upper_Ascii : Translate_Table;
Lower_Ascii : Translate_Table;
Equal_Mod_Case : Equality_Table := (others => (others => False));
subtype Translation is Integer range 0 .. 2 ** 8 - 1;
-- Next_Cap is 0..1 * 2**7
-- Lower_Char is 0..127
type Caps_Array is array (Translation) of Translation;
Caps : Caps_Array;
Char : constant Translation := 2 ** 7;
Base_Characters : array (0 .. 15) of Character :=
('0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
procedure Capitalize (S : in out String) is
Upper : Translation := 0;
begin
for I in S'Range loop
declare
C : Character renames S (I);
T : Translation renames Caps (Character'Pos (C) + Upper);
begin
C := Character'Val (T mod Char);
Upper := T - Character'Pos (C);
end;
end loop;
end Capitalize;
function Capitalize (S : String) return String is
Upper : Translation := 0;
New_S : String (S'Range) := S;
begin
for I in New_S'Range loop
declare
C : Character renames New_S (I);
T : Translation renames Caps (Character'Pos (C) + Upper);
begin
C := Character'Val (T mod Char);
Upper := T - Character'Pos (C);
end;
end loop;
return New_S;
end Capitalize;
function Upper_Case (C : Character) return Character is
begin
return Upper_Ascii (C);
end Upper_Case;
function Lower_Case (C : Character) return Character is
begin
return Lower_Ascii (C);
end Lower_Case;
procedure Upper_Case (C : in out Character) is
begin
C := Upper_Ascii (C);
end Upper_Case;
procedure Lower_Case (C : in out Character) is
begin
C := Lower_Ascii (C);
end Lower_Case;
procedure Upper_Case (S : in out String) is
begin
for I in S'Range loop
S (I) := Upper_Ascii (S (I));
end loop;
end Upper_Case;
procedure Lower_Case (S : in out String) is
begin
for I in S'Range loop
S (I) := Lower_Ascii (S (I));
end loop;
end Lower_Case;
function Upper_Case (S : String) return String is
New_S : String (S'First .. S'Last);
begin
for I in S'Range loop
New_S (I) := Upper_Ascii (S (I));
end loop;
return New_S;
end Upper_Case;
function Lower_Case (S : String) return String is
New_S : String (S'First .. S'Last);
begin
for I in S'Range loop
New_S (I) := Lower_Ascii (S (I));
end loop;
return New_S;
end Lower_Case;
-- It is expected that specific targets will be able to get better hashes
-- using code insertions.
function Hash_String (S : String) return Integer is
L : constant Integer := S'Length;
Result : Integer := L;
begin
if L > 0 then
Result := Result +
2 ** 5 * Character'Pos (Upper_Ascii (S (S'First))) +
Character'Pos
(Upper_Ascii
(S (S'First + (1 + S'Last - S'First) / 2))) +
2 ** 3 * Character'Pos (Upper_Ascii (S (S'Last)));
end if;
return Result;
end Hash_String;
function Number_To_String (Value : Integer;
Base : Natural := 10;
Width : Natural := 0;
Leading : Character := ' ') return String is
Sign : Boolean := False;
Result : Bounded_String.Variable_String (80);
Ch : Integer;
procedure N2s (Num : Integer; Width : Integer) is
begin
if Num = 0 then
-- Handle leading stuff
for I in 1 .. Width loop
Bounded_String.Append (Result, Leading);
end loop;
if Sign then
Bounded_String.Append (Result, '-');
end if;
if Value = 0 then
if Width > 0 then
Bounded_String.Replace
(Result, Bounded_String.Length (Result), '0');
else
Bounded_String.Append (Result, '0');
end if;
end if;
else
N2s (Num / Base, Width - 1);
if not Sign then
Ch := Num mod Base;
else
Ch := Base - Num mod Base;
if Ch = Base then
Ch := 0;
end if;
end if;
Bounded_String.Append (Result, Base_Characters (Ch));
end if;
end N2s;
begin
Bounded_String.Set_Length (Result, 0);
if Value < 0 then
Sign := True;
N2s (Value, Width - 1);
else
N2s (Value, Width);
end if;
return Bounded_String.Image (Result);
end Number_To_String;
-- the above used to be the long_integer version
-- function Number_To_String (Value : Integer;
-- Base : Natural := 10;
-- Width : Natural := 0;
-- Leading : Character := ' ') return String is
-- begin
-- return Number_To_String (Long_Integer (Value), Base, Width, Leading);
-- end Number_To_String;
-- the following used to be the long_integer version
procedure String_To_Number (Source : String;
Target : out Integer;
Worked : out Boolean;
Base : Natural := 10) is
Sign : Integer;
Result : Integer;
Ch : Character;
Char_Val : Integer;
Prefix : Boolean := True;
begin
Worked := False;
Target := 0;
Result := 0;
Sign := +1;
for I in Source'Range loop
Ch := Source (I);
if Ch = ' ' then
if not Prefix then
return;
end if;
else
if Prefix and Ch = '-' then
Sign := -1;
else
if Ch in '0' .. '9' then
Char_Val := (Character'Pos (Ch) - 48);
else
Upper_Case (Ch);
if Ch in 'A' .. 'F' then
Char_Val := Character'Pos (Ch) -
Character'Pos ('A') + 10;
else
-- set Char_Val > any legal base
Char_Val := 500;
end if;
end if;
if Char_Val >= Base then
return;
end if;
Result := Result * Base + Char_Val;
end if;
Prefix := False;
end if;
end loop;
if Source'Length /= 0 and then
(Source'Length > 1 or else Sign = +1) then
Target := Result * Sign;
Worked := True;
end if;
exception
when others =>
Worked := False;
end String_To_Number;
-- procedure String_To_Number (Source : String;
-- Target : out Integer;
-- Worked : out Boolean;
-- Base : Natural := 10) is
-- Result : Long_Integer;
-- begin
-- String_To_Number (Source, Result, Worked, Base);
-- Target := Integer (Result);
-- end String_To_Number;
function Locate (Fragment : Character;
Within : String;
Ignore_Case : Boolean := False) return Natural is
begin
if Ignore_Case then
for I in Within'Range loop
if Equal_Mod_Case (Fragment, Within (I)) then
return I;
end if;
end loop;
else
for I in Within'Range loop
if Fragment = Within (I) then
return I;
end if;
end loop;
end if;
return 0;
end Locate;
function Locate (Fragment : String;
Within : String;
Ignore_Case : Boolean := False) return Natural is
Dec_Length : Integer := Fragment'Length - 1;
First : Positive := Fragment'First;
First_Char : Character;
begin
if Dec_Length >= 1 then
First_Char := Fragment (First);
if Ignore_Case then
for I in Within'First .. Within'Last - Dec_Length loop
if Equal_Mod_Case (Within (I), First_Char) then
for J in reverse 1 .. Dec_Length loop
if not Equal_Mod_Case (Fragment (First + J),
Within (I + J)) then
exit;
elsif J = 1 then
return I;
end if;
end loop;
end if;
end loop;
else
for I in Within'First .. Within'Last - Dec_Length loop
if Within (I) = First_Char then
for J in reverse 1 .. Dec_Length loop
if Fragment (First + J) /= Within (I + J) then
exit;
elsif J = 1 then
return I;
end if;
end loop;
end if;
end loop;
end if;
return 0;
elsif Dec_Length = 0 then
return Locate (Fragment (First), Within, Ignore_Case);
else
return Within'First;
end if;
end Locate;
function Reverse_Locate (Fragment : Character;
Within : String;
Ignore_Case : Boolean := False) return Natural is
begin
if Ignore_Case then
for I in reverse Within'Range loop
if Equal_Mod_Case (Fragment, Within (I)) then
return I;
end if;
end loop;
else
for I in reverse Within'Range loop
if Fragment = Within (I) then
return I;
end if;
end loop;
end if;
return 0;
end Reverse_Locate;
function Reverse_Locate (Fragment : String;
Within : String;
Ignore_Case : Boolean := False) return Natural is
Dec_Length : Integer := Fragment'Length - 1;
First : Positive := Fragment'First;
First_Char : Character;
begin
if Dec_Length >= 1 then
First_Char := Fragment (First);
if Ignore_Case then
for I in reverse Within'First .. Within'Last - Dec_Length loop
if Equal_Mod_Case (Within (I), First_Char) then
for J in reverse 1 .. Dec_Length loop
if not Equal_Mod_Case (Fragment (First + J),
Within (I + J)) then
exit;
elsif J = 1 then
return I + Dec_Length;
end if;
end loop;
end if;
end loop;
else
for I in reverse Within'First .. Within'Last - Dec_Length loop
if Within (I) = First_Char then
for J in reverse 1 .. Dec_Length loop
if Fragment (First + J) /= Within (I + J) then
exit;
elsif J = 1 then
return I + Dec_Length;
end if;
end loop;
end if;
end loop;
end if;
return 0;
elsif Dec_Length = 0 then
return Reverse_Locate (Fragment (First), Within, Ignore_Case);
else
return Within'Last;
end if;
end Reverse_Locate;
function Equal
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean is
Length : Integer := Str1'Length;
First1 : Positive := Str1'First;
First2 : Positive := Str2'First;
begin
if Length = Str2'Length then
if Ignore_Case then
for I in 0 .. Length - 1 loop
if not Equal_Mod_Case (Str1 (First1 + I),
Str2 (First2 + I)) then
return False;
end if;
end loop;
return True;
else
return Str1 = Str2;
end if;
else
return False;
end if;
end Equal;
function Less_Than
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean is
begin
if Ignore_Case then
return Lower_Case (Str1) < Lower_Case (Str2);
else
return Str1 < Str2;
end if;
end Less_Than;
function Greater_Than
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean is
begin
if Ignore_Case then
return Lower_Case (Str1) > Lower_Case (Str2);
else
return Str1 > Str2;
end if;
end Greater_Than;
function Strip_Leading
(From : String; Filler : Character := ' ') return String is
begin
for I in From'First .. From'Last loop
if From (I) /= Filler then
return From (I .. From'Last);
end if;
end loop;
return "";
end Strip_Leading;
function Strip_Trailing
(From : String; Filler : Character := ' ') return String is
begin
for I in reverse From'First .. From'Last loop
if From (I) /= Filler then
return From (From'First .. I);
end if;
end loop;
return "";
end Strip_Trailing;
function Strip (From : String; Filler : Character := ' ') return String is
begin
return Strip_Leading (Strip_Trailing (From, Filler), Filler);
end Strip;
begin
for C in Character loop
Upper_Ascii (C) := C;
Equal_Mod_Case (C, C) := True;
end loop;
Lower_Ascii := Upper_Ascii;
for C in 'A' .. 'Z' loop
Lower_Ascii (C) := Character'Val (Character'Pos (C) + 32);
Equal_Mod_Case (C, Lower_Ascii (C)) := True;
end loop;
for C in 'a' .. 'z' loop
Upper_Ascii (C) := Character'Val (Character'Pos (C) - 32);
Equal_Mod_Case (C, Upper_Ascii (C)) := True;
end loop;
declare
Alphanumeric : Integer;
Upper : Character;
Lower : Character;
begin
for C in Character loop
Upper := Upper_Ascii (C);
Lower := Lower_Ascii (C);
Alphanumeric := Boolean'Pos
(Upper /= Lower or else C in '0' .. '9') * Char;
Caps (Character'Pos (C)) := Alphanumeric + Character'Pos (Upper);
Caps (Character'Pos (C) + Char) :=
Alphanumeric + Character'Pos (Lower);
end loop;
end;
end String_Utilities;with Text_Io;
-- This package is used to produce neatly formatted tables with centered
-- headers and even amounts of white space between the columns. The first
-- N calls should be to header, which defines a header and a type of
-- justification for the items that will go into each column. Then the M*N
-- items of an M line table are sent into the package a row at a time. An
-- item is defined by either a single call to Item, or a series of zero or
-- more calls to Subitem terminated by a call to Last_Subitem. Multiple
-- parts of an item are separated by the subitem separator. After all the
-- items have been defined, the table is output with a call to Display.
-- The package internally allocates enough memory to save a copy of the
-- entire table. It is therefore a good idea to instantiate this
-- procedure in a local frame so that all the memory it allocates will go
-- away when the frame does.
generic
Number_Of_Columns : Positive;
Subitem_Separator : String := " ";
package Table_Formatter is
type Adjust is (Left, Right, Centered);
procedure Header (S : String; Format : Adjust := Left);
procedure Item (S : String);
procedure Subitem (S : String);
procedure Last_Subitem;
procedure Display (On_File : Text_Io.File_Type);
type Field_List is array (Integer range <>) of Positive;
procedure Sort (On_Field : Positive := 1);
procedure Sort (On_Fields : Field_List);
end Table_Formatter;with Table_Sort_Generic;
package body Table_Formatter is
Intercolumn_Spacing : constant := 2;
subtype Column_Index is Natural range 1 .. Number_Of_Columns;
type Width_List is array (Column_Index) of Natural;
type A_String is access String;
type An_Item (Subitem_Length : Natural);
type Access_Item is access An_Item;
type An_Item (Subitem_Length : Natural) is
record
Subitem : String (1 .. Subitem_Length);
Next : Access_Item;
end record;
type Item_List is array (Column_Index) of Access_Item;
type Line;
type Access_Line is access Line;
type Access_Line_Array is array (Integer range <>) of Access_Line;
Current_Line : Access_Line;
type Line is
record
Values : Item_List;
Width : Width_List := (others => 0);
Next : Access_Line := Current_Line;
end record;
Current_Column : Column_Index := Column_Index'Last;
In_Subitem : Boolean := False;
Max_Width : Width_List := (others => 0);
Headers : array (Column_Index) of A_String;
Header_Column : Natural := 0;
Column_Format : array (Column_Index) of Adjust;
function Max (Left, Right : Integer) return Integer is
begin
if Left >= Right then
return Left;
else
return Right;
end if;
end Max;
procedure Insert (S : String) is
-- Put the String into the current row/column, appending it if
-- there is already something there.
Cell : Access_Item renames Current_Line.Values (Current_Column);
Width : Natural renames Current_Line.Width (Current_Column);
Max : Natural renames Max_Width (Current_Column);
begin
if Cell = null then
Width := S'Length;
else
Width := Width + Subitem_Separator'Length + S'Length;
end if;
if Width > Max then
Max := Width;
end if;
Cell := new An_Item'(S'Length, S, Cell);
end Insert;
procedure Item (S : String) is
-- Begin a new cell, put S there, and mark the cell closed by
-- setting In_Subitem to be false.
begin
if Current_Column = Column_Index'Last then
Current_Line := new Line;
Current_Column := Column_Index'First;
else
Current_Column := Current_Column + 1;
end if;
Insert (S);
In_Subitem := False;
end Item;
procedure Header (S : String; Format : Adjust := Left) is
-- Set Header and Column Format
begin
Header_Column := Header_Column + 1;
Column_Format (Header_Column) := Format;
Headers (Header_Column) := new String'(S);
end Header;
procedure Subitem (S : String) is
-- If the current cell is open, add S to it. Otherwise start a new
-- cell, but leave it open.
begin
if In_Subitem then
Insert (S);
else
Item (S);
end if;
In_Subitem := True;
end Subitem;
procedure Last_Subitem is
-- If the current cell is open, close it. If the current cell is
-- closed, we have an item that consists of zero subitems. Give it
-- a visible representation.
begin
if In_Subitem then
In_Subitem := False;
else
Item ("(none)");
end if;
end Last_Subitem;
function Image (P : Access_Item) return String is
-- P must be non-null
begin
if P.Next = null then
return P.Subitem;
end if;
return Image (P.Next) & Subitem_Separator & P.Subitem;
-- Recall that subitem lists are stored in reverse order
end Image;
procedure Display (On_File : Text_Io.File_Type) is
-- Dump the data structure we have been building by traversing it
-- recursively. Note that all of the lists are stored in reverse
-- order so that they were easy to build.
procedure Replicate (C : Character; N : Natural) is
-- Output N copies of C
S : constant String (1 .. N) := (others => C);
begin
Text_Io.Put (On_File, S);
end Replicate;
procedure Display (P : Access_Item) is
begin
if P /= null then
Text_Io.Put (On_File, Image (P));
end if;
end Display;
procedure Display_Headers is
Excess : Width_List;
begin
for J in Column_Index loop
Excess (J) := Max (Headers (J).all'Length, Max_Width (J)) -
Headers (J).all'Length;
end loop;
Replicate (' ', Excess (1) / 2);
for J in Column_Index loop
Text_Io.Put (On_File, Headers (J).all);
if J /= Column_Index'Last then
Replicate (' ', (Excess (J) + 1) / 2 + Excess (J + 1) / 2 +
Intercolumn_Spacing);
end if;
end loop;
Text_Io.New_Line (On_File);
end Display_Headers;
procedure Display_Adjusted (L : Line) is
Inner_Excess, Outer_Excess : Natural;
begin
for J in Column_Index loop
Inner_Excess := Max_Width (J) - L.Width (J);
Outer_Excess :=
Max (Headers (J).all'Length, Max_Width (J)) - Max_Width (J);
case Column_Format (J) is
when Left =>
Replicate (' ', Outer_Excess / 2);
Display (L.Values (J));
if J /= Column_Index'Last then
Replicate (' ',
(Outer_Excess + 1) / 2 + Inner_Excess +
Intercolumn_Spacing);
end if;
when Right =>
Replicate (' ', Outer_Excess / 2 + Inner_Excess);
Display (L.Values (J));
if J /= Column_Index'Last then
Replicate (' ', (Outer_Excess + 1) / 2 +
Intercolumn_Spacing);
end if;
when Centered =>
Replicate (' ', (Inner_Excess + Outer_Excess) / 2);
Display (L.Values (J));
if J /= Column_Index'Last then
Replicate (' ',
(Inner_Excess + Outer_Excess + 1) / 2 +
Intercolumn_Spacing);
end if;
end case;
end loop;
Text_Io.New_Line (On_File);
end Display_Adjusted;
procedure Display (L : Access_Line) is
begin
if L = null then
-- Center the header
Display_Headers;
-- A separator line
for J in Column_Index loop
Replicate ('=', Max
(Headers (J).all'Length, Max_Width (J)));
if J /= Column_Index'Last then
Replicate (' ', Intercolumn_Spacing);
end if;
end loop;
Text_Io.New_Line (On_File);
else
-- Display the head of the table
Display (L.Next);
-- Display the final line
Display_Adjusted (L.all);
end if;
end Display;
begin
Display (Current_Line);
end Display;
function Normalize return Natural is
-- Traverse the current structure looking for cells that consist
-- of more than one subitem, and concatentate the subitems into
-- a single item.
-- Return the number of rows in the table.
Result : Natural := 0;
Line : Access_Line := Current_Line;
P : Access_Item;
begin
while Line /= null loop
for J in Line.Values'Range loop
P := Line.Values (J);
if P = null then
Line.Values (J) := new An_Item'(0, "", null);
elsif P.Next /= null then
Line.Values (J) :=
new An_Item'(Line.Width (J), Image (P), null);
end if;
end loop;
Line := Line.Next;
Result := Result + 1;
end loop;
return Result;
end Normalize;
procedure Fill (Table : out Access_Line_Array) is
-- Transfers the linked list pointed to by Current_Line into
-- the sequential table.
P : Access_Line;
begin
P := Current_Line;
for J in reverse Table'Range loop
Table (J) := P;
P := P.Next;
end loop;
end Fill;
procedure Empty (Table : Access_Line_Array) is
-- rebuilds the Current_Line link list from the sequential table,
-- preserving the convention that lists are stored backwards.
begin
if Table'Length = 0 then
Current_Line := null;
return;
end if;
Table (Table'First).Next := null;
for J in Table'First + 1 .. Table'Last loop
Table (J).Next := Table (J - 1);
end loop;
Current_Line := Table (Table'Last);
end Empty;
procedure Sort (On_Field : Positive := 1) is
Table : Access_Line_Array (1 .. Normalize);
function "<" (Left, Right : Access_Line) return Boolean is
begin
return Left.Values (On_Field).Subitem <
Right.Values (On_Field).Subitem;
end "<";
procedure Table_Sort is
new Table_Sort_Generic (Element => Access_Line,
Index => Integer,
Element_Array => Access_Line_Array);
begin
Fill (Table);
Table_Sort (Table);
Empty (Table);
end Sort;
procedure Sort (On_Fields : Field_List) is
Table : Access_Line_Array (1 .. Normalize);
function "<" (Left, Right : Access_Line) return Boolean is
begin
for J in On_Fields'Range loop
if Left.Values (On_Fields (J)).Subitem <
Right.Values (On_Fields (J)).Subitem then
return True;
end if;
if Left.Values (On_Fields (J)).Subitem >
Right.Values (On_Fields (J)).Subitem then
return False;
end if;
end loop;
return False;
end "<";
procedure Table_Sort is
new Table_Sort_Generic (Element => Access_Line,
Index => Integer,
Element_Array => Access_Line_Array);
begin
Fill (Table);
Table_Sort (Table);
Empty (Table);
end Sort;
begin
-- Default to empty left justified headers.
for J in Column_Index loop
Column_Format (J) := Left;
Headers (J) := new String'("");
end loop;
end Table_Formatter;generic
type Element is private;
pragma Must_Be_Constrained (Yes => Element);
type Index is (<>);
type Element_Array is array (Index range <>) of Element;
with function "<" (Left, Right : Element) return Boolean is <>;
procedure Table_Sort_Generic (Table : in out Element_Array);procedure Table_Sort_Generic (Table : in out Element_Array) is
First_Index : Integer := Index'Pos (Table'First);
Last_Index : Integer := Index'Pos (Table'Last);
J : Integer;
Jg : Integer;
Gap : Integer;
Temp : Element;
begin
Gap := Last_Index - First_Index;
while Gap > 0 loop
for I in Index'Val (Gap + First_Index) .. Table'Last loop
J := Index'Pos (I) - Gap;
while J >= First_Index loop
Jg := J + Gap;
declare
Op1 : Element renames Table (Index'Val (J));
Op2 : Element renames Table (Index'Val (Jg));
begin
if Op2 < Op1 then
Temp := Op1;
Op1 := Op2;
Op2 := Temp;
else
exit;
end if;
end;
J := J - Gap;
end loop;
end loop;
Gap := Gap / 2;
end loop;
end Table_Sort_Generic;with Calendar;
package Time_Utilities is
Minute : constant Duration := 60.0;
Hour : constant Duration := 3600.0;
Day : constant Duration := 86_400.0;
--------------------------------------------------------------------
-- Time_Utilities.Time is a segmented version of Calendar.Time
-- with image and value functions
--------------------------------------------------------------------
type Years is new Calendar.Year_Number;
type Months is (January, February, March, April, May, June, July,
August, September, October, November, December);
type Days is new Calendar.Day_Number;
type Hours is new Integer range 1 .. 12;
type Minutes is new Integer range 0 .. 59;
type Seconds is new Integer range 0 .. 59;
type Sun_Positions is (Am, Pm);
type Time is
record
Year : Years;
Month : Months;
Day : Days;
Hour : Hours;
Minute : Minutes;
Second : Seconds;
Sun_Position : Sun_Positions;
end record;
function Get_Time return Time;
function Convert_Time (Date : Calendar.Time) return Time;
function Convert_Time (Date : Time) return Calendar.Time;
function Nil return Time;
function Is_Nil (Date : Time) return Boolean;
function Nil return Calendar.Time;
function Is_Nil (Date : Calendar.Time) return Boolean;
type Time_Format is (Expanded, -- 11:00:00 PM
Military, -- 23:00:00
Short, -- 23:00
Ada -- 23_00_00
);
type Date_Format is (Expanded, -- September 29, 1983
Month_Day_Year, -- 09/29/83
Day_Month_Year, -- 29-SEP-83
Year_Month_Day, -- 83/09/29
Ada -- 83_09_29
);
type Image_Contents is (Both, Time_Only, Date_Only);
function Image (Date : Time;
Date_Style : Date_Format := Time_Utilities.Expanded;
Time_Style : Time_Format := Time_Utilities.Expanded;
Contents : Image_Contents := Time_Utilities.Both)
return String;
function Value (S : String) return Time;
-- Gives incorrect results for dates earlier than 1924.
--------------------------------------------------------------------
-- Time_Utilities.Interval is a segmented version of Duration
-- with image and value functions
--------------------------------------------------------------------
type Day_Count is new Integer range 0 .. Integer'Last;
type Military_Hours is new Integer range 0 .. 23;
type Milliseconds is new Integer range 0 .. 999;
type Interval is
record
Elapsed_Days : Day_Count;
Elapsed_Hours : Military_Hours;
Elapsed_Minutes : Minutes;
Elapsed_Seconds : Seconds;
Elapsed_Milliseconds : Milliseconds;
end record;
function Convert (I : Interval) return Duration;
function Convert (D : Duration) return Interval;
function Image (I : Interval) return String;
function Value (S : String) return Interval;
function Image (D : Duration) return String;
function Duration_Until (T : Time) return Duration;
function Duration_Until (T : Calendar.Time) return Duration;
function Duration_Until_Next
(H : Military_Hours; M : Minutes := 0; S : Seconds := 0)
return Duration;
-- Day of week support; Monday is 1.
type Weekday is new Positive range 1 .. 7;
function Day_Of_Week (T : Calendar.Time) return Weekday;
function Day_Of_Week (T : Time := Get_Time) return Weekday;
function Image (D : Weekday) return String;
function "+" (D : Weekday; I : Integer) return Weekday;
function "-" (D : Weekday; I : Integer) return Weekday;
end Time_Utilities;with Enumeration_Value;
with Machine_Independent_Integer32;
with String_Utilities;
package body Time_Utilities is
package Mii renames Machine_Independent_Integer32;
subtype Integer32 is Mii.Integer32;
function "+" (L, R : Integer32) return Integer32 renames Mii."+";
function "-" (L, R : Integer32) return Integer32 renames Mii."-";
function "*" (L : Integer32; R : Integer) return Integer32 renames Mii."*";
function "/" (L : Integer32; R : Integer) return Integer32 renames Mii."/";
function "=" (L, R : Integer32) return Boolean renames Mii."=";
function "<" (L, R : Integer32) return Boolean renames Mii."<";
Zero : constant Integer32 := Integer32 (0);
Seconds_Per_Minute : constant := 60;
Seconds_Per_Hour : constant := 60 * Seconds_Per_Minute;
Seconds_Per_Half_Day : constant := 12 * Seconds_Per_Hour;
Null_Calendar_Time : Calendar.Time;
type Number_Array is array (Positive range <>) of Natural;
type Character_Map is array (Character) of Boolean;
Is_Numeric : constant Character_Map :=
Character_Map'('0' | '1' | '2' | '3' | '4' |
'5' | '6' | '7' | '8' | '9' => True,
others => False);
Is_Alphabetic : constant Character_Map :=
Character_Map'('a' .. 'z' | 'A' .. 'Z' => True, others => False);
Null_Time : constant Time := Time'(Year => Years'First,
Month => Months'First,
Day => Days'First,
Hour => Hours'First,
Minute => Minutes'First,
Second => Seconds'First,
Sun_Position => Sun_Positions'First);
Null_Interval : constant Interval :=
Interval'(Elapsed_Days => Day_Count'First,
Elapsed_Hours => Military_Hours'First,
Elapsed_Minutes => Minutes'First,
Elapsed_Seconds => Seconds'First,
Elapsed_Milliseconds => Milliseconds'First);
Military_Hour : constant array (Sun_Positions, Hours) of Military_Hours :=
(Am => (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 0),
Pm => (13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 12));
-- used in day of week calculation
Days_In_Month : constant array (Months) of Integer :=
(January | March | May | July | August | October | December => 31,
April | June | September | November => 30,
February => 28);
function Image (Value : Integer;
Base : Natural := 10;
Width : Natural := 2;
Leading : Character := '0') return String
renames String_Utilities.Number_To_String;
package Interval_Value is
-- Hack to get around RCG bug
function Value (S : String) return Interval;
end Interval_Value;
procedure Unique_Prefix is new Enumeration_Value (Months);
function Convert_Time (Date : Calendar.Time) return Time is
Result : Time;
C_Year : Calendar.Year_Number;
C_Month : Calendar.Month_Number;
C_Day : Calendar.Day_Number;
C_Second : Calendar.Day_Duration;
Total_Seconds : Integer32;
Hour_Offset : Integer32;
Junk, Min, Sec : Integer32;
begin
Calendar.Split (Date, C_Year, C_Month, C_Day, C_Second);
Result.Year := Years (C_Year);
Result.Month := Months'Val (C_Month - 1);
Result.Day := Days (C_Day);
Total_Seconds := Integer32 (C_Second);
if Total_Seconds < Integer32 (Seconds_Per_Half_Day) then
Result.Sun_Position := Am;
else
Result.Sun_Position := Pm;
Total_Seconds := Total_Seconds - Integer32 (Seconds_Per_Half_Day);
end if;
Hour_Offset := Total_Seconds / Seconds_Per_Hour;
if Hour_Offset = Zero then
Result.Hour := 12;
Result.Sun_Position := Pm;
else
Result.Hour := Hours (Hour_Offset);
end if;
--- Total_Seconds := Total_Seconds rem Seconds_Per_Hour; --tjl was MOD
Mii.Div_Rem (Total_Seconds, Seconds_Per_Hour, Junk, Total_Seconds);
Mii.Div_Rem (Total_Seconds, Seconds_Per_Minute, Min, Sec);
Result.Minute := Minutes (Min);
Result.Second := Seconds (Sec);
--- Result.Minute := Minutes (Total_Seconds / Seconds_Per_Minute);
--- Result.Second := Seconds (Total_Seconds rem Seconds_Per_Minute);--tjl
return Result;
end Convert_Time;
function Convert_Time (Date : Time) return Calendar.Time is
C_Year : Calendar.Year_Number;
C_Month : Calendar.Month_Number;
C_Day : Calendar.Day_Number;
Total_Seconds : Integer32;
begin
C_Year := Calendar.Year_Number (Date.Year);
C_Month := Calendar.Month_Number (Months'Pos (Date.Month) + 1);
C_Day := Calendar.Day_Number (Date.Day);
Total_Seconds := Integer32 (Date.Second) +
Integer32 (Date.Minute) * Seconds_Per_Minute;
if Date.Hour /= 12 then
Total_Seconds := Total_Seconds +
Integer32 (Date.Hour) * Seconds_Per_Hour;
end if;
if Date.Sun_Position = Pm then
Total_Seconds := Total_Seconds + Integer32 (Seconds_Per_Half_Day);
end if;
return Calendar.Time_Of (C_Year, C_Month, C_Day,
Duration (Total_Seconds));
exception
when Calendar.Time_Error =>
return Calendar.Clock;
end Convert_Time;
function Get_Time return Time is
begin
return Convert_Time (Calendar.Clock);
end Get_Time;
function Image (Month : Months; Full_Width : Boolean := True)
return String is
Name : constant String := Months'Image (Month);
begin
if Full_Width then
return String_Utilities.Capitalize (Name);
else
return Name (Name'First .. Name'First + 2);
end if;
end Image;
function Time_Image (Date : Time; Time_Style : Time_Format) return String is
Sep : Character := ':';
Hour : Integer := Integer (Military_Hour
(Date.Sun_Position, Date.Hour));
begin
case Time_Style is
when Expanded =>
return Image (Integer (Date.Hour), Width => 0) &
Sep & Image (Integer (Date.Minute)) & Sep &
Image (Integer (Date.Second)) & ' ' &
Sun_Positions'Image (Date.Sun_Position);
when Military | Ada =>
if Time_Style = Ada then
Sep := '_';
end if;
return Image (Hour) & Sep & Image (Integer (Date.Minute)) &
Sep & Image (Integer (Date.Second));
when Short =>
return Image (Hour) & Sep & Image (Integer (Date.Minute));
end case;
end Time_Image;
function Date_Image (Date : Time; Date_Style : Date_Format) return String is
Sep : Character := '/';
Year : Integer := Integer (Date.Year) mod 100;
Month : Integer := Months'Pos (Date.Month) + 1;
begin
case Date_Style is
when Expanded =>
return Image (Date.Month) & ' ' &
Image (Integer (Date.Day), Width => 0) & ',' &
Image (Integer (Date.Year),
Leading => ' ',
Width => 5);
when Month_Day_Year =>
return Image (Month, Leading => ' ') & Sep &
Image (Integer (Date.Day)) & Sep & Image (Year);
when Day_Month_Year =>
Sep := '-';
return Image (Integer (Date.Day), Leading => ' ') & Sep &
Image (Date.Month, Full_Width => False) &
Sep & Image (Year);
when Year_Month_Day | Ada =>
if Date_Style = Ada then
Sep := '_';
end if;
return Image (Year) & Sep & Image (Month) &
Sep & Image (Integer (Date.Day));
end case;
end Date_Image;
function Separator (Date_Style : Date_Format; Time_Style : Time_Format)
return String is
begin
if Date_Style = Ada and then Time_Style = Ada then
return "_at_";
elsif Date_Style = Expanded then
return " at ";
else
return " ";
end if;
end Separator;
function Image (Date : Time;
Date_Style : Date_Format := Expanded;
Time_Style : Time_Format := Expanded;
Contents : Image_Contents := Both) return String is
begin
case Contents is
when Both =>
return Date_Image (Date, Date_Style) &
Separator (Date_Style, Time_Style) &
Time_Image (Date, Time_Style);
when Date_Only =>
return Date_Image (Date, Date_Style);
when Time_Only =>
return Time_Image (Date, Time_Style);
end case;
end Image;
function Time_Stamp_Image
(Date : Time := Get_Time; Style : Time_Format := Military)
return String is
begin
if Style = Short then
return Image (Integer (Date.Minute)) & ':' &
Image (Integer (Date.Second));
else
return Time_Image (Date, Style);
end if;
end Time_Stamp_Image;
function Convert (I : Interval) return Duration is
Seconds : Duration := Duration (I.Elapsed_Milliseconds) / 1000;
begin
Seconds := Duration (I.Elapsed_Seconds) + Seconds;
Seconds := Duration (Duration (I.Elapsed_Minutes) * Minute) + Seconds;
Seconds := Duration (Duration (I.Elapsed_Hours) * Hour) + Seconds;
Seconds := Duration (Duration (I.Elapsed_Days) * Day) + Seconds;
return Seconds;
end Convert;
function Convert (D : Duration) return Interval is
I : Interval;
Milliseconds_Per_Second : constant := 1000;
Milliseconds_Per_Minute : constant := 60 * Milliseconds_Per_Second;
Milliseconds_Per_Hour : constant := 60 * Milliseconds_Per_Minute;
Milliseconds_Per_Day : constant := 24 * Milliseconds_Per_Hour;
Rest : Integer32 := Integer32 (D) * Milliseconds_Per_Second
;
begin
if D < 0.0 then
return Null_Interval;
end if;
I.Elapsed_Days := Day_Count (Rest / Milliseconds_Per_Day);
Rest := Rest - (Integer32 (I.Elapsed_Days) * Milliseconds_Per_Day);
I.Elapsed_Hours := Military_Hours (Rest / Milliseconds_Per_Hour);
Rest := Rest - (Integer32 (I.Elapsed_Hours) * Milliseconds_Per_Hour);
I.Elapsed_Minutes := Minutes (Rest / Milliseconds_Per_Minute);
Rest := Rest - (Integer32 (I.Elapsed_Minutes) *
Milliseconds_Per_Minute);
I.Elapsed_Seconds := Seconds (Rest / Milliseconds_Per_Second);
Rest := Rest - (Integer32 (I.Elapsed_Seconds) *
Milliseconds_Per_Second);
I.Elapsed_Milliseconds := Milliseconds (Rest);
return I;
end Convert;
package body Interval_Value is separate;
function Value (S : String) return Interval is
begin
return Interval_Value.Value (S);
end Value;
function Time_Value (S : String) return Time is separate;
function Value (S : String) return Time is
begin
return Time_Value (S);
end Value;
function Image (D : Duration) return String is
begin
return Image (Convert (D));
end Image;
function Image (I : Interval) return String is
begin
if I.Elapsed_Days > 99999 then
return Image (Natural (I.Elapsed_Days), Width => 0) & 'D';
elsif I.Elapsed_Days > 99 then
return Image
(Natural (I.Elapsed_Days), Width => 5, Leading => ' ') &
'/' & Image (Natural (I.Elapsed_Hours));
elsif I.Elapsed_Days > 0 then
return Image (Natural (I.Elapsed_Days), Leading => ' ') &
'/' & Image (Natural (I.Elapsed_Hours)) &
':' & Image (Natural (I.Elapsed_Minutes));
elsif I.Elapsed_Hours > 0 then
return Image (Natural (I.Elapsed_Hours), Leading => ' ') &
':' & Image (Natural (I.Elapsed_Minutes)) &
':' & Image (Natural (I.Elapsed_Seconds));
elsif I.Elapsed_Minutes > 0 then
return Image (Natural (I.Elapsed_Minutes), Leading => ' ') &
':' & Image (Natural (I.Elapsed_Seconds)) & '.' &
Image (Natural (I.Elapsed_Milliseconds), Width => 3);
else
return Image (Natural (I.Elapsed_Seconds), Leading => ' ') & '.' &
Image (Natural (I.Elapsed_Milliseconds), Width => 3);
end if;
end Image;
function Nil return Time is
begin
return Null_Time;
end Nil;
function Is_Nil (Date : Time) return Boolean is
begin
return Date = Nil;
end Is_Nil;
function Nil return Calendar.Time is
begin
return Null_Calendar_Time;
end Nil;
function Is_Nil (Date : Calendar.Time) return Boolean is
begin
return Calendar."=" (Date, Nil);
end Is_Nil;
function Image (D : Weekday) return String is
begin
case D is
when 1 =>
return "Monday";
when 2 =>
return "Tuesday";
when 3 =>
return "Wednesday";
when 4 =>
return "Thursday";
when 5 =>
return "Friday";
when 6 =>
return "Saturday";
when 7 =>
return "Sunday";
end case;
end Image;
function Make_Weekday (D : Integer) return Weekday is
Day : Integer := D mod 7;
begin
if Day = 0 then
return 7;
else
return Weekday (Day);
end if;
end Make_Weekday;
pragma Inline (Make_Weekday);
function Day_Of_Week (T : Time := Get_Time) return Weekday is
-- Uses Zeller's congruence to compute the day of week of given date.
-- See "Problems for Computer Solutions", Gruenberger & Jaffray, Wiley,
-- 1965, p. 255ff.
Zyear, Zmonth, Zcentury, Zyy : Integer;
begin
-- Remap month# so Mar=1 & Jan, Feb=11, 12 of PRECEDING year
if Months'Pos (T.Month) >= 3 then
Zyear := Integer (T.Year);
Zmonth := Months'Pos (T.Month) - 1;
else -- Jan or Feb
Zyear := Integer (T.Year) - 1;
Zmonth := Months'Pos (T.Month) + 11;
end if;
Zcentury := Zyear / 100;
Zyy := Zyear rem 100;
return Make_Weekday (((26 * Zmonth - 2) / 10) + Integer (T.Day) +
Zyy + (Zyy / 4) + (Zcentury / 4) - 2 * Zcentury);
end Day_Of_Week;
function Day_Of_Week (T : Calendar.Time) return Weekday is
begin
return Day_Of_Week (Convert_Time (T));
end Day_Of_Week;
function "+" (D : Weekday; I : Integer) return Weekday is
begin
return Make_Weekday (Integer (D) + I);
end "+";
function "-" (D : Weekday; I : Integer) return Weekday is
begin
return Make_Weekday (Integer (D) - I);
end "-";
function Duration_Until (T : Calendar.Time) return Duration is
begin
return Calendar."-" (T, Calendar.Clock);
end Duration_Until;
function Duration_Until (T : Time) return Duration is
begin
return Duration_Until (Convert_Time (T));
end Duration_Until;
function Duration_Until_Next
(H : Military_Hours; M : Minutes := 0; S : Seconds := 0)
return Duration is
T : Time := Get_Time;
D : Duration;
Hr : Natural := Natural (H);
begin
T.Minute := M;
T.Second := S;
if Hr >= 12 then
T.Sun_Position := Pm;
Hr := Hr - 12;
else
T.Sun_Position := Am;
end if;
if Hr = 0 then
T.Hour := 12;
else
T.Hour := Hours (Hr);
end if;
D := Duration_Until (T);
if D < 0.0 then
D := Day + D;
end if;
return D;
end Duration_Until_Next;
begin
Null_Calendar_Time := Convert_Time (Null_Time);
end Time_Utilities;separate (Time_Utilities)
package body Interval_Value is
function Value (S : String) return Interval is
-- format is ddDhh:mm:ss.milli
-- upper or lower case D is a deliminator
-- all non-numeric non delimiters are ignored
-- if only one : is given, it is assumed to separate hrs and seconds
-- 10:17 is 10hrs 17min, :10:17 is 0hrs 10min 17sec
Position : Natural := S'First;
Result : Interval;
type Kind_Value is (Day, Hour, Minute, Second, Millisecond, Number);
type Item;
type Item_Ptr is access Item;
type Item is
record
Kind : Kind_Value;
Value : Natural;
Next : Item_Ptr;
end record;
First_Item : Item_Ptr;
Last_Item : Item_Ptr;
Dot_Observed : Boolean := False;
Colons_Observed : Natural := 0;
function Is_Digit (Char : Character) return Boolean is
begin
case Char is
when '0' .. '9' =>
return True;
when others =>
return False;
end case;
end Is_Digit;
function Is_Delimiter (Char : Character) return Boolean is
begin
case Char is
when ':' | 'D' | 'd' | '/' | '.' =>
return True;
when others =>
return False;
end case;
end Is_Delimiter;
function Get_Number return Item_Ptr is
Start : Natural := Position;
Last : Natural;
function Pad_To_Three_Digits (S : String) return Natural is
begin
if S'Length = 1 then
return Natural'Value (S & "00");
elsif S'Length = 2 then
return Natural'Value (S & '0');
else
return Natural'Value (S (S'First .. S'First + 2));
end if;
end Pad_To_Three_Digits;
function Get_Item (N : Natural) return Item_Ptr is
begin
return new Item'(Kind => Number, Value => N, Next => null);
end Get_Item;
begin
while Position <= S'Last and then Is_Digit (S (Position)) loop
Position := Position + 1;
end loop;
if Position <= S'Last then
Last := Position - 1;
else
Last := S'Last;
end if;
if Dot_Observed then
return Get_Item (Pad_To_Three_Digits (S (Start .. Last)));
else
return Get_Item (Natural'Value (S (Start .. Last)));
end if;
end Get_Number;
function Get_Item return Item_Ptr is
Char : Character;
function Item_Value (Ch : Character) return Item_Ptr is
Result : Item_Ptr := new Item;
begin
case Ch is
when 'D' | 'd' | '/' =>
Result.Kind := Day;
when ':' =>
Result.Kind := Hour;
Colons_Observed := Colons_Observed + 1;
if Colons_Observed > 2 then
raise Constraint_Error;
end if;
when '.' =>
Result.Kind := Second;
Dot_Observed := True;
when others =>
raise Constraint_Error;
end case;
return Result;
end Item_Value;
begin
while Position <= S'Last loop
Char := S (Position);
if Is_Delimiter (Char) then
Position := Position + 1;
return Item_Value (Char);
elsif Is_Digit (Char) then
return Get_Number;
else
Position := Position + 1;
end if;
end loop;
return null;
end Get_Item;
procedure Build_List (First, Last : in out Item_Ptr) is
Next_Item : Item_Ptr;
begin
-- build list of items
Next_Item := Get_Item;
First := Next_Item;
Last := First;
loop
Next_Item := Get_Item;
exit when Next_Item = null;
Last.Next := Next_Item;
Last := Next_Item;
end loop;
end Build_List;
procedure Normalize (First, Last : in out Item_Ptr) is
Hour_Item : Item_Ptr;
Next_Item : Item_Ptr := First;
procedure Add (Kind : Kind_Value) is
New_Item : Item_Ptr := new Item'(Kind, 0, null);
begin
Last.Next := New_Item;
Last := New_Item;
end Add;
begin
if Colons_Observed = 2 or else Dot_Observed then
-- find right_most hour and make it minute
while Next_Item /= null loop
if Next_Item.Kind = Hour then
Hour_Item := Next_Item;
end if;
Next_Item := Next_Item.Next;
end loop;
if Hour_Item /= null then
Hour_Item.Kind := Minute;
end if;
end if;
if Last.Kind = Number then
if Dot_Observed then
Add (Millisecond);
else
case Colons_Observed is
when 2 =>
Add (Second);
when 1 =>
Add (Minute);
when 0 =>
Add (Hour);
when others =>
raise Constraint_Error;
end case;
end if;
end if;
end Normalize;
function Build_Value (First, Last : Item_Ptr) return Interval is
Number_Kind : constant Kind_Value := Number;
Result : Interval := Null_Interval;
Next_Item : Item_Ptr := First;
Number : Natural := 0;
procedure Get_Number (Ptr : in out Item_Ptr;
Value : in out Natural) is
begin
if Ptr.Kind = Number_Kind then
Value := Ptr.Value;
Ptr := Ptr.Next;
else
Value := 0;
end if;
end Get_Number;
procedure Set_Field (Kind : Kind_Value;
Number : Natural;
Result : in out Interval) is
Value : Natural := Number;
begin
if Value = 0 then
return;
end if;
case Next_Item.Kind is
when Day =>
Result.Elapsed_Days :=
Result.Elapsed_Days + Day_Count (Value);
when Hour =>
Value := Value + Natural (Result.Elapsed_Hours);
Set_Field (Day, Value / 24, Result);
Result.Elapsed_Hours := Military_Hours (Value mod 24);
when Minute =>
Value := Value + Natural (Result.Elapsed_Minutes);
Set_Field (Hour, Value / 60, Result);
Result.Elapsed_Minutes := Minutes (Value mod 60);
when Second =>
Value := Value + Natural (Result.Elapsed_Seconds);
Set_Field (Minute, Value / 60, Result);
Result.Elapsed_Seconds := Seconds (Value mod 60);
when Millisecond =>
Value := Value + Natural (Result.Elapsed_Milliseconds);
Set_Field (Second, Value / 1000, Result);
Result.Elapsed_Milliseconds :=
Milliseconds (Value mod 1000);
when others =>
raise Constraint_Error;
end case;
end Set_Field;
begin
while Next_Item /= null loop
Get_Number (Next_Item, Number);
-- increments next_item (if appropriate)
Set_Field (Next_Item.Kind, Number, Result);
Next_Item := Next_Item.Next;
end loop;
return Result;
end Build_Value;
begin
Build_List (First_Item, Last_Item);
Normalize (First_Item, Last_Item);
return Build_Value (First_Item, Last_Item);
end Value;
end Interval_Value;separate (Time_Utilities)
function Time_Value (S : String) return Time is
-- accepts all of the formats output by value
-- algorithm consists of parsing for a series of numbers
-- and assigning them to positions in the date according
-- to heuristics about size and position.
-- recognizes unique prefixes of month names
Pm_Detected : Boolean := False;
Month_Position : Integer := 0;
function Value (Month : Positive;
Day : Natural;
Year : Natural;
Hour : Natural;
Minute : Natural;
Second : Natural) return Time is
Result : Time;
begin
if Year < 100 then
Result.Year := Years (Integer'(1900 + Year));
else
Result.Year := Years (Year);
end if;
Result.Month := Months'Val (Month - 1);
Result.Day := Days (Day);
Result.Minute := Minutes (Minute);
Result.Second := Seconds (Second);
case Hour is
when 0 =>
Result.Sun_Position := Am;
Result.Hour := 12;
when 12 =>
Result.Sun_Position := Pm;
Result.Hour := 12;
when others =>
if Hour > 12 then
Result.Sun_Position := Pm;
Result.Hour := Hours (Hour - 12);
else
if Pm_Detected then
Result.Sun_Position := Pm;
else
Result.Sun_Position := Am;
end if;
Result.Hour := Hours (Hour);
end if;
end case;
return Result;
end Value;
function This_Year return Natural is
begin
return Natural (Get_Time.Year);
end This_Year;
function Value (Number : Number_Array) return Time is
Now : Time;
begin
case Number'Length is
when 6 =>
case Month_Position is
when 1 =>
-- May 1, 1985 at 00:00:00
return Value (Number (1), Number (2), Number (3),
Number (4), Number (5), Number (6));
when 2 =>
-- 1-May-85 at 00:00:00
return Value (Number (2), Number (1), Number (3),
Number (4), Number (5), Number (6));
when 4 =>
-- 00:00:00 May 1, 1985
return Value (Number (4), Number (5), Number (6),
Number (1), Number (2), Number (3));
when 5 =>
-- 00:00:00 1-May-85
return Value (Number (5), Number (4), Number (6),
Number (1), Number (2), Number (3));
when 0 =>
-- no alphabetic year given
if Number (1) > 23 then
-- 85/5/1 00:00:00
return Value (Number (2), Number (3), Number (1),
Number (4), Number (5), Number (6));
else
-- 5/1/85 00:00:00
return Value (Number (1), Number (2), Number (3),
Number (4), Number (5), Number (6));
end if;
when others =>
raise Constraint_Error;
end case;
when 5 =>
case Month_Position is
when 1 =>
-- May 1, 1985 at 00:00
return Value (Number (1), Number (2), Number (3),
Number (4), Number (5), 0);
when 2 =>
-- 1-May-85 at 00:00
return Value (Number (2), Number (1), Number (3),
Number (4), Number (5), 0);
when 3 =>
-- 00:00 May 1, 1985
return Value (Number (3), Number (4), Number (5),
Number (1), Number (2), 0);
when 5 =>
-- 00:00:00 1-May
return Value (Number (5), Number (4),
Natural (Get_Time.Year), Number (1),
Number (2), Number (3));
when 0 =>
-- no alphabetic year given
if Number (1) > 23 then
-- 85/5/1 00:00
return Value (Number (2), Number (3), Number (1),
Number (4), Number (5), 0);
elsif Number (3) > 23 then
-- 5/1/85 00:00
return Value (Number (1), Number (2), Number (3),
Number (4), Number (5), 0);
else
-- 5/1 00:00:00
return Value (Number (1), Number (2),
Natural (Get_Time.Year), Number (3),
Number (4), Number (5));
end if;
when others =>
raise Constraint_Error;
end case;
when 4 =>
case Month_Position is
when 0 | 1 =>
-- 5/1 00:00
-- May 1 00:00
return Value (Number (1), Number (2),
Natural (Get_Time.Year),
Number (3), Number (4), 0);
when 2 =>
-- 1-May 00:00
return Value (Number (2), Number (1),
Natural (Get_Time.Year),
Number (3), Number (4), 0);
when others =>
raise Constraint_Error;
end case;
when 3 =>
Now := Get_Time;
case Month_Position is
when 0 =>
if Number (1) > 23 then
-- 85/5/1
Pm_Detected := Now.Sun_Position = Pm;
return Value (Number (2), Number (3),
Number (1), Natural (Now.Hour),
Natural (Now.Minute),
Natural (Now.Second));
elsif Number (3) > 59 then
-- 5/1/85
Pm_Detected := Now.Sun_Position = Pm;
return Value (Number (1), Number (2),
Number (3), Natural (Now.Hour),
Natural (Now.Minute),
Natural (Now.Second));
else
-- 00:00:00
return Value (Natural (Months'Pos (Now.Month) + 1),
Natural (Now.Day), Natural (Now.Year),
Number (1), Number (2), Number (3));
end if;
when 1 =>
-- May 1, 1985
Pm_Detected := Now.Sun_Position = Pm;
return Value (Number (1), Number (2), Number (3),
Natural (Now.Hour), Natural (Now.Minute),
Natural (Now.Second));
when 2 =>
-- 1-May-85
Pm_Detected := Now.Sun_Position = Pm;
return Value (Number (2), Number (1), Number (3),
Natural (Now.Hour), Natural (Now.Minute),
Natural (Now.Second));
when others =>
raise Constraint_Error;
end case;
when 2 =>
Now := Get_Time;
case Month_Position is
when 0 =>
-- 00:00
return Value (Natural (Months'Pos (Now.Month) + 1),
Natural (Now.Day), Natural (Now.Year),
Number (1), Number (2), 0);
when 1 =>
-- May 1
Pm_Detected := Now.Sun_Position = Pm;
return Value (Number (1), Number (2),
Natural (Now.Year), Natural (Now.Hour),
Natural (Now.Minute),
Natural (Now.Second));
when 2 =>
-- 1-May
Pm_Detected := Now.Sun_Position = Pm;
return Value (Number (2), Number (1),
Natural (Now.Year), Natural (Now.Hour),
Natural (Now.Minute),
Natural (Now.Second));
when others =>
raise Constraint_Error;
end case;
when others =>
raise Constraint_Error;
end case;
end Value;
procedure Find_Number (S : String;
First : Positive;
Position : out Positive;
Success : out Boolean) is
begin
for I in First .. S'Last loop
if Is_Numeric (S (I)) then
Success := True;
Position := I;
return;
end if;
end loop;
Position := First;
Success := False;
end Find_Number;
procedure Find_Non_Number
(S : String; First : Positive; Position : out Positive) is
begin
for I in First .. S'Last loop
if not Is_Numeric (S (I)) then
Position := I;
return;
end if;
end loop;
Position := S'Last + 1;
end Find_Non_Number;
procedure Find_Alphabetic (S : String;
First : Positive;
Position : out Positive;
Success : out Boolean) is
begin
for I in First .. S'Last loop
exit when Is_Numeric (S (I));
if Is_Alphabetic (S (I)) then
Success := True;
Position := I;
return;
end if;
end loop;
Position := First;
Success := False;
end Find_Alphabetic;
procedure Find_Non_Alphabetic
(S : String; First : Positive; Position : out Positive) is
begin
for I in First .. S'Last loop
if not Is_Alphabetic (S (I)) then
Position := I;
return;
end if;
end loop;
Position := S'Last + 1;
end Find_Non_Alphabetic;
procedure Get_Number (S : String;
First : in out Positive;
Result : out Natural;
Success : out Boolean) is
Found : Boolean;
Start : Positive;
begin
Find_Number (S, First, Start, Found);
if not Found then
Success := False;
Result := 0;
return;
end if;
Find_Non_Number (S, Start, First);
Success := True;
Result := Natural'Value (S (Start .. First - 1));
end Get_Number;
procedure Get_Month (S : String;
First : in out Positive;
Result : out Natural;
Success : out Boolean) is
Found : Boolean;
Start : Natural;
Stop : Natural;
Prefix : Boolean;
M : Months;
begin
Find_Alphabetic (S, First, Start, Found);
if Found then
Find_Non_Alphabetic (S, Start, Stop);
Unique_Prefix (S (Start .. Stop - 1), M, Prefix, Found);
if Found then
Result := Months'Pos (M) + 1;
First := Stop;
Success := True;
return;
end if;
end if;
Success := False;
Result := 0;
exception
when others =>
Result := 0;
Success := False;
end Get_Month;
function Get_Number_Array (S : String) return Number_Array is
Result : Number_Array (1 .. 6);
First : Positive := S'First;
Success : Boolean;
I : Integer := Result'First;
begin
Pm_Detected :=
String_Utilities.Locate ("PM", S, Ignore_Case => True) /= 0;
while I <= Result'Last loop
if Month_Position = 0 and then First <= S'Last and then
not Is_Numeric (S (First)) then
Get_Month (S, First, Result (I), Success);
if Success then
Month_Position := I;
I := I + 1;
exit when I > Result'Last;
end if;
end if;
Get_Number (S, First, Result (I), Success);
if not Success then
return Result (1 .. I - 1);
end if;
I := I + 1;
end loop;
return Result;
end Get_Number_Array;
begin
return Value (Get_Number_Array (String_Utilities.Strip (S)));
end Time_Value;package Trig_Lib is
function Sin (X : Float) return Float;
function Cos (X : Float) return Float;
function Tan (X : Float) return Float;
function Cot (X : Float) return Float;
function Asin (X : Float) return Float;
function Acos (X : Float) return Float;
function Atan (X : Float) return Float;
function Atan2 (V, U : Float) return Float;
function Sinh (X : Float) return Float;
function Cosh (X : Float) return Float;
function Tanh (X : Float) return Float;
end Trig_Lib;with Text_Io;
use Text_Io;
with Floating_Characteristics;
use Floating_Characteristics;
with Numeric_Io;
use Numeric_Io;
with Numeric_Primitives;
use Numeric_Primitives;
with Core_Functions;
use Core_Functions;
package body Trig_Lib is
-- PRELIMINARY VERSION *********************************
-- The following routines are coded directly from the algorithms and
-- coeficients given in "Software Manual for the Elementry Functions"
-- by William J. Cody, Jr. and William Waite, Prentice_Hall, 1980
-- This particular version is stripped to work with FLOAT and INTEGER
-- and uses a mantissa represented as a FLOAT
-- A more general formulation uses MANTISSA_TYPE, etc.
-- The coeficients are appropriate for 25 to 32 bits floating significance
-- They will work for less but slightly shorter versions are possible
-- The routines are coded to stand alone so they need not be compiled together
-- 16 JULY 1982 W A WHITAKER AFATL EGLIN AFB FL 32542
-- T C EICHOLTZ USAFA
function Sin (X : Float) return Float is
Sgn, Y : Float;
N : Integer;
Xn : Float;
F, G, X1, X2 : Float;
Result : Float;
Ymax : Float := Float (Integer (Pi * Two ** (It / 2)));
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
C1 : constant Float := 3.140625;
C2 : constant Float := 9.6765_35897_93E-4;
function R (G : Float) return Float is
R1 : constant Float := -0.16666_66660_883;
R2 : constant Float := 0.83333_30720_556E-2;
R3 : constant Float := -0.19840_83282_313E-3;
R4 : constant Float := 0.27523_97106_775E-5;
R5 : constant Float := -0.23868_34640_601E-7;
begin
return ((((R5 * G + R4) * G + R3) * G + R2) * G + R1) * G;
end R;
begin
if X < Zero then
Sgn := -One;
Y := -X;
else
Sgn := One;
Y := X;
end if;
if Y > Ymax then
New_Line;
Put (" SIN CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
New_Line;
end if;
N := Integer (Y * One_Over_Pi);
Xn := Convert_To_Float (N);
if N mod 2 /= 0 then
Sgn := -Sgn;
end if;
X1 := Truncate (abs (X));
X2 := abs (X) - X1;
F := ((X1 - Xn * C1) + X2) - Xn * C2;
if abs (F) < Epsilon then
Result := F;
else
G := F * F;
Result := F + F * R (G);
end if;
return (Sgn * Result);
end Sin;
function Cos (X : Float) return Float is
Sgn, Y : Float;
N : Integer;
Xn : Float;
F, G, X1, X2 : Float;
Result : Float;
Ymax : Float := Float (Integer (Pi * Two ** (It / 2)));
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
C1 : constant Float := 3.140625;
C2 : constant Float := 9.6765_35897_93E-4;
function R (G : Float) return Float is
R1 : constant Float := -0.16666_66660_883;
R2 : constant Float := 0.83333_30720_556E-2;
R3 : constant Float := -0.19840_83282_313E-3;
R4 : constant Float := 0.27523_97106_775E-5;
R5 : constant Float := -0.23868_34640_601E-7;
begin
return ((((R5 * G + R4) * G + R3) * G + R2) * G + R1) * G;
end R;
begin
Sgn := 1.0;
Y := abs (X) + Pi_Over_Two;
if Y > Ymax then
New_Line;
Put (" COS CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
New_Line;
end if;
N := Integer (Y * One_Over_Pi);
Xn := Convert_To_Float (N);
if N mod 2 /= 0 then
Sgn := -Sgn;
end if;
Xn := Xn - 0.5; -- TO FORM COS INSTEAD OF SIN
X1 := Truncate (abs (X));
X2 := abs (X) - X1;
F := ((X1 - Xn * C1) + X2) - Xn * C2;
if abs (F) < Epsilon then
Result := F;
else
G := F * F;
Result := F + F * R (G);
end if;
return (Sgn * Result);
end Cos;
function Tan (X : Float) return Float is
Sgn, Y : Float;
N : Integer;
Xn : Float;
F, G, X1, X2 : Float;
Result : Float;
Ymax : Float := Float (Integer (Pi * Two ** (It / 2))) / 2.0;
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
C1 : constant Float := 8#1.444#;
C2 : constant Float := 4.8382_67948_97E-4;
function R (G : Float) return Float is
P0 : constant Float := 1.0;
P1 : constant Float := -0.11136_14403_566;
P2 : constant Float := 0.10751_54738_488E-2;
Q0 : constant Float := 1.0;
Q1 : constant Float := -0.44469_47720_281;
Q2 : constant Float := 0.15973_39213_300E-1;
begin
return ((P2 * G + P1) * G * F + F) /
(((Q2 * G + Q1) * G + 0.5) + 0.5);
end R;
begin
Y := abs (X);
if Y > Ymax then
New_Line;
Put (" TAN CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
New_Line;
end if;
N := Integer (X * Two_Over_Pi);
Xn := Convert_To_Float (N);
X1 := Truncate (X);
X2 := X - X1;
F := ((X1 - Xn * C1) + X2) - Xn * C2;
if abs (F) < Epsilon then
Result := F;
else
G := F * F;
Result := R (G);
end if;
if N mod 2 = 0 then
return Result;
else
return -1.0 / Result;
end if;
end Tan;
function Cot (X : Float) return Float is
Sgn, Y : Float;
N : Integer;
Xn : Float;
F, G, X1, X2 : Float;
Result : Float;
Ymax : Float := Float (Integer (Pi * Two ** (It / 2))) / 2.0;
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
Epsilon1 : Float := 1.0 / Xmax;
C1 : constant Float := 8#1.444#;
C2 : constant Float := 4.8382_67948_97E-4;
function R (G : Float) return Float is
P0 : constant Float := 1.0;
P1 : constant Float := -0.11136_14403_566;
P2 : constant Float := 0.10751_54738_488E-2;
Q0 : constant Float := 1.0;
Q1 : constant Float := -0.44469_47720_281;
Q2 : constant Float := 0.15973_39213_300E-1;
begin
return ((P2 * G + P1) * G * F + F) /
(((Q2 * G + Q1) * G + 0.5) + 0.5);
end R;
begin
Y := abs (X);
if Y < Epsilon1 then
New_Line;
Put (" COT CALLED WITH ARGUMENT TOO NEAR ZERO ");
New_Line;
if X < 0.0 then
return -Xmax;
else
return Xmax;
end if;
end if;
if Y > Ymax then
New_Line;
Put (" COT CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
New_Line;
end if;
N := Integer (X * Two_Over_Pi);
Xn := Convert_To_Float (N);
X1 := Truncate (X);
X2 := X - X1;
F := ((X1 - Xn * C1) + X2) - Xn * C2;
if abs (F) < Epsilon then
Result := F;
else
G := F * F;
Result := R (G);
end if;
if N mod 2 /= 0 then
return -Result;
else
return 1.0 / Result;
end if;
end Cot;
function Asin (X : Float) return Float is
G, Y : Float;
Result : Float;
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
function R (G : Float) return Float is
P1 : constant Float := -0.27516_55529_0596E1;
P2 : constant Float := 0.29058_76237_4859E1;
P3 : constant Float := -0.59450_14419_3246;
Q0 : constant Float := -0.16509_93320_2424E2;
Q1 : constant Float := 0.24864_72896_9164E2;
Q2 : constant Float := -0.10333_86707_2113E2;
Q3 : constant Float := 1.0;
begin
return (((P3 * G + P2) * G + P1) * G) /
(((G + Q2) * G + Q1) * G + Q0);
end R;
begin
return X;
end Asin;
function Acos (X : Float) return Float is
G, Y : Float;
Result : Float;
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
function R (G : Float) return Float is
P1 : constant Float := -0.27516_55529_0596E1;
P2 : constant Float := 0.29058_76237_4859E1;
P3 : constant Float := -0.59450_14419_3246;
Q0 : constant Float := -0.16509_93320_2424E2;
Q1 : constant Float := 0.24864_72896_9164E2;
Q2 : constant Float := -0.10333_86707_2113E2;
Q3 : constant Float := 1.0;
begin
return (((P3 * G + P2) * G + P1) * G) /
(((G + Q2) * G + Q1) * G + Q0);
end R;
begin
return X;
end Acos;
function Atan (X : Float) return Float is
F, G : Float;
subtype Region is Integer range 0 .. 3; -- ##########
N : Region;
Result : Float;
Beta : Float := Convert_To_Float (Ibeta);
Epsilon : Float := Beta ** (-It / 2);
Sqrt_3 : constant Float := 1.73205_08075_68877_29353;
Sqrt_3_Minus_1 : constant Float := 0.73205_08075_68877_29353;
Two_Minus_Sqrt_3 : constant Float := 0.26794_91924_31122_70647;
function R (G : Float) return Float is
P0 : constant Float := -0.14400_83448_74E1;
P1 : constant Float := -0.72002_68488_98;
Q0 : constant Float := 0.43202_50389_19E1;
Q1 : constant Float := 0.47522_25845_99E1;
Q2 : constant Float := 1.0;
begin
return ((P1 * G + P0) * G) / ((G + Q1) * G + Q0);
end R;
begin
F := abs (X);
if F > 1.0 then
F := 1.0 / F;
N := 2;
else
N := 0;
end if;
if F > Two_Minus_Sqrt_3 then
F := (((Sqrt_3_Minus_1 * F - 0.5) - 0.5) + F) / (Sqrt_3 + F);
N := N + 1;
end if;
if abs (F) < Epsilon then
Result := F;
else
G := F * F;
Result := F + F * R (G);
end if;
if N > 1 then
Result := -Result;
end if;
case N is
when 0 =>
Result := Result;
when 1 =>
Result := Pi_Over_Six + Result;
when 2 =>
Result := Pi_Over_Two + Result;
when 3 =>
Result := Pi_Over_Three + Result;
end case;
if X < 0.0 then
Result := -Result;
end if;
return Result;
end Atan;
function Atan2 (V, U : Float) return Float is
X, Result : Float;
begin
if U = 0.0 then
if V = 0.0 then
Result := 0.0;
New_Line;
Put (" ATAN2 CALLED WITH 0/0 RETURNED ");
New_Line;
elsif V > 0.0 then
Result := Pi_Over_Two;
else
Result := -Pi_Over_Two;
end if;
else
X := abs (V / U);
-- If underflow or overflow is detected, go to the exception
Result := Atan (X);
if U < 0.0 then
Result := Pi - Result;
end if;
if V < 0.0 then
Result := -Result;
end if;
end if;
return Result;
exception
when Numeric_Error =>
if abs (V) > abs (U) then
Result := Pi_Over_Two;
if V < 0.0 then
Result := -Result;
end if;
else
Result := 0.0;
if U < 0.0 then
Result := Pi - Result;
end if;
end if;
return Result;
end Atan2;
function Sinh (X : Float) return Float is
begin
return X;
end Sinh;
function Cosh (X : Float) return Float is
begin
return X;
end Cosh;
function Tanh (X : Float) return Float is
begin
return X;
end Tanh;
begin
null;
end Trig_Lib;generic
Default_Maximum_Length : Natural := 20;
package Unbounded_String is
-------------------------------------------------------------------------------
-- Managed Pointer Sequential Unbounded Strings:
-- Restrictions and assumptions
-- Storage management performed
-- All new allocations for extensions are twice requirements
-- CANNOT be used by multiple tasks unless user guarantees sequential use
-- := is reference copy, use copy to assign contents
-- uninitialized or Free'd objects are true null's and changes to one
-- of the referents will not be reflected in the other;
-- use Free prior to assignment to prevent garbage
-- = is object identity, use string_utilities for comparison
--
-------------------------------------------------------------------------------
subtype String_Length is Natural;
type Variable_String is private;
-- release storage associated with a string
procedure Free (V : in out Variable_String);
-- Get information about current length or contents of a string
function Length (Source : Variable_String) return String_Length;
function Char_At (Source : Variable_String; At_Pos : Positive)
return Character;
function Extract (Source : Variable_String;
Start_Pos : Positive;
End_Pos : Natural) return String;
function Image (V : Variable_String) return String;
function Value (S : String) return Variable_String;
-- Image (Target) := Image (Source);
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);
-- Target := Source; Source := ""; with appropriate storage management
procedure Move (Target : in out Variable_String;
Source : in out Variable_String);
-- Target := Target & Source;
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 : String_Length);
-- Target := Target (1..At_Pos-1) & Source & Target (At_Pos..Target'Length)
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 : String_Length);
-- Target (At_Pos .. At_Pos + Count -1) := "";
procedure Delete (Target : in out Variable_String;
At_Pos : Positive;
Count : String_Length := 1);
-- Target (At_Pos .. At_Pos + Source'Length - 1) := Source;
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 : String_Length);
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);
-- Target'Length := New_Length;
-- Target (Target'Length .. New_Length) := Fill_With;
procedure Set_Length (Target : in out Variable_String;
New_Length : String_Length;
Fill_With : Character := ' ');
private
type Pointer is access String;
type Real_String;
type Variable_String is access Real_String;
subtype String_Bound is Integer range -1 .. Integer'Last;
type Real_String is
record
Length : String_Bound;
Contents : Pointer;
Next_Free : Variable_String;
end record;
Null_String : Pointer := new String (1 .. 0);
Free_List_Item : constant String_Bound := -1;
Free_List : Real_String :=
Real_String'(Free_List_Item, Null_String,
new Real_String'(Free_List_Item, Null_String, null));
end Unbounded_String;package body Unbounded_String is
function Max (X : Integer; Y : Integer) return Integer is
begin
if X > Y then
return X;
else
return Y;
end if;
end Max;
pragma Inline (Max);
procedure Free (V : in out Variable_String) is
begin
if V /= null then
if V.Length /= Free_List_Item then
V.Next_Free := Free_List.Next_Free;
V.Length := Free_List_Item;
Free_List.Next_Free := V;
end if;
V := null;
end if;
end Free;
function Length (Source : Variable_String) return String_Length is
begin
if Source /= null then
return Source.Length;
else
return 0;
end if;
exception
when others =>
return 0;
end Length;
function Allocated_Length (Source : Variable_String) return String_Length is
begin
if Source /= null and then Source.Length /= Free_List_Item then
return Source.Contents'Length;
else
return 0;
end if;
end Allocated_Length;
procedure Real_Allocate (Target : in out Variable_String;
Length : String_Length;
Room_For_Growth : Boolean := True) is
function Allocation (Length : String_Length) return String_Length is
begin
if Room_For_Growth then
return Max (2 * Length, Default_Maximum_Length);
else
return Max (Length, Default_Maximum_Length);
end if;
end Allocation;
procedure Find (Free : in out Real_String;
This : in out Variable_String) is
begin
This := Free.Next_Free;
if This /= null then
if This.Contents'Length > Length then
Free.Next_Free := This.Next_Free;
This.Next_Free := null;
else
Find (This.all, This);
end if;
end if;
end Find;
begin
Find (Free_List, Target);
if Target = null then
Target := new Real_String'
(Length => Length,
Contents => new String (1 .. Allocation (Length)),
Next_Free => null);
else
Target.Length := Length;
Target.Next_Free := null;
end if;
end Real_Allocate;
procedure Move (Target : in out Variable_String;
Source : in out Variable_String) is
begin
Free (Target);
Target := Source;
Source := null;
end Move;
procedure Allocate (Target : in out Variable_String;
Length : String_Length;
Preserve_Contents : Boolean := True) is
Max_Length : String_Length := Allocated_Length (Target);
begin
-- check for alias of freed string and remove pointer to free list
if Max_Length = 0 then
Real_Allocate (Target, Length, Room_For_Growth => False);
elsif Max_Length >= Length then
Target.Length := Length;
else
declare
Temp : Variable_String;
begin
Real_Allocate (Temp, Length, Preserve_Contents);
if Preserve_Contents then
Temp.Contents (1 .. Target.Length) :=
Target.Contents (1 .. Target.Length);
end if;
Move (Target, Temp);
end;
end if;
end Allocate;
function Value (S : String) return Variable_String is
Result : Variable_String;
begin
Real_Allocate (Result, S'Length, Room_For_Growth => False);
Copy (Result, S);
return Result;
end Value;
procedure Copy (Target : in out Variable_String;
Source : Variable_String) is
begin
Copy (Target, Image (Source));
end Copy;
procedure Copy (Target : in out Variable_String; Source : String) is
begin
Allocate (Target, Source'Length, Preserve_Contents => False);
declare
T : Real_String renames Target.all;
begin
T.Contents (1 .. Source'Length) := Source;
T.Length := Source'Length;
end;
end Copy;
procedure Copy (Target : in out Variable_String; Source : Character) is
begin
Allocate (Target, 1, Preserve_Contents => False);
Target.Contents (1) := Source;
end Copy;
function Image (V : Variable_String) return String is
begin
return V.all.Contents (1 .. V.all.Length);
exception
when others =>
return String'(1 .. 0 => ' ');
end Image;
procedure Append (Target : in out Variable_String; Source : String) is
Len : String_Length := Length (Target);
begin
Allocate (Target, Len + Source'Length, Preserve_Contents => True);
declare
T : Real_String renames Target.all;
begin
T.Contents (Len + 1 .. T.Length) := Source;
end;
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 : String_Length := Length (Target) + 1;
begin
Allocate (Target, Len, Preserve_Contents => True);
Target.Contents (Len) := Source;
end Append;
procedure Append (Target : in out Variable_String;
Source : Character;
Count : String_Length) 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
Len : String_Length := Length (Target);
begin
if At_Pos = Len + 1 then
Append (Target, Source);
elsif At_Pos <= Len then
Allocate (Target, Len + Source'Length);
declare
T : Real_String renames Target.all;
begin
T.Contents (At_Pos .. T.Length) :=
Source & T.Contents (At_Pos .. 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, Image (Source));
end Insert;
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Character) is
Len : String_Length := Length (Target) + 1;
begin
if At_Pos = Len then
Append (Target, Source);
elsif At_Pos > Len then
raise Constraint_Error;
else
Allocate (Target, Len, Preserve_Contents => True);
declare
T : Real_String renames Target.all;
begin
T.Contents (At_Pos + 1 .. Len) :=
T.Contents (At_Pos .. Len - 1);
T.Contents (At_Pos) := Source;
end;
end if;
end Insert;
procedure Insert (Target : in out Variable_String;
At_Pos : Positive;
Source : Character;
Count : String_Length) 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 : String_Length := 1) is
T : Real_String renames Target.all;
Len : String_Length := T.Length - Count;
begin
if At_Pos - 1 > Len then
raise Constraint_Error;
end if;
if At_Pos <= Len then
T.Contents (At_Pos .. Len) :=
T.Contents (At_Pos + Count .. T.Length);
end if;
T.Length := Len;
end Delete;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Character) is
T : Real_String renames Target.all;
begin
if At_Pos > T.Length then
raise Constraint_Error;
else
T.Contents (At_Pos) := Source;
end if;
end Replace;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : String) is
T : Real_String renames Target.all;
End_Pos : constant Natural -- not positive JMK 28 Sep 84
:= At_Pos + Source'Length - 1;
begin
if End_Pos > T.Length then
raise Constraint_Error;
else
T.Contents (At_Pos .. End_Pos) := Source;
end if;
end Replace;
procedure Replace (Target : in out Variable_String;
At_Pos : Positive;
Source : Character;
Count : String_Length) 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 : String_Length;
Fill_With : Character := ' ') is
Current_Length : String_Length := Length (Target);
begin
if New_Length > Current_Length then
Allocate (Target, New_Length, Preserve_Contents => True);
declare
C : String renames Target.Contents.all;
begin
for I in Current_Length + 1 .. New_Length loop
C (I) := Fill_With;
end loop;
end;
elsif Target /= null then
Target.Length := New_Length;
end if;
end Set_Length;
function Char_At (Source : Variable_String; At_Pos : Positive)
return Character is
S : Real_String renames Source.all;
begin
if At_Pos > S.Length then
raise Constraint_Error;
else
return S.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 Unbounded_String