|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B D M R T V ┃
Length: 228268 (0x37bac)
Types: R1K_ARCHIVE_DATA, TextFile
Names: »DATA«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─ ⟦6f12a12be⟧ »DATA«
└─⟦this⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─ ⟦d65440be7⟧ »DATA«
└─⟦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;
INDEX: ⟦6c5555414⟧ R1K_ARCHIVE_INDEX DATA: ⟦9b477e385⟧ R1K_ARCHIVE_DATA, TextFile
0x00000…00ef7 ⟦a61fc1b33⟧ 0x00ef7…02e21 ⟦b1a22725d⟧ 0x02e21…03cdc ⟦4771a9fdb⟧ 0x03cdc…065ce ⟦e2acccd93⟧ 0x065ce…06777 ⟦b3867145c⟧ 0x06777…0a62b ⟦fed769ff7⟧ 0x0a62b…0a720 ⟦3234ae6f9⟧ 0x0a720…0abd6 ⟦e2101317a⟧ 0x0abd6…0c1c8 ⟦a5f87a3e3⟧ 0x0c1c8…0e128 ⟦9d78b1705⟧ 0x0e128…0e6f3 ⟦542922de3⟧ 0x0e6f3…0ed0a ⟦0bd5f6717⟧ 0x0ed0a…0f03b ⟦8fe15431f⟧ 0x0f03b…0f2d3 ⟦7fcfa08b6⟧ 0x0f2d3…1017a ⟦e895802c4⟧ 0x1017a…11758 ⟦00165936c⟧ 0x11758…118f9 ⟦bf031df25⟧ 0x118f9…15990 ⟦fc4cf5bf4⟧ 0x15990…1603a ⟦1c0bbedf7⟧ 0x1603a…16d81 ⟦b9a400e68⟧ 0x16d81…173c8 ⟦e77559783⟧ 0x173c8…17aa1 ⟦5ac55847a⟧ 0x17aa1…181bb ⟦f53809862⟧ 0x181bb…189ae ⟦83d22651a⟧ 0x189ae…18d8b ⟦45771e695⟧ 0x18d8b…19580 ⟦aa5d4c50f⟧ 0x19580…1a110 ⟦ca85a278a⟧ 0x1a110…1b8e0 ⟦cf7e9341c⟧ 0x1b8e0…1c0c2 ⟦38a93f2bb⟧ 0x1c0c2…1d5bf ⟦90180af14⟧ 0x1d5bf…1e1c9 ⟦5237038ed⟧ 0x1e1c9…221c3 ⟦49ee8ac96⟧ 0x221c3…2277c ⟦14c84e96e⟧ 0x2277c…25411 ⟦90b99a8d4⟧ 0x25411…25545 ⟦ccd5b9857⟧ 0x25545…2597f ⟦3b498eefe⟧ 0x2597f…26a0e ⟦0f1fd616e⟧ 0x26a0e…2ad23 ⟦c33d138f9⟧ 0x2ad23…2d026 ⟦bef1e4ed8⟧ 0x2d026…3079b ⟦03ee9b8d7⟧ 0x3079b…309ab ⟦f72d7a424⟧ 0x309ab…33aeb ⟦0319a08b0⟧ 0x33aeb…34ecb ⟦e556502e5⟧ 0x34ecb…37bac ⟦1510af14f⟧