Examples

Generics

Generic Stack Package

Stack Specification (stack.ads)

generic
   type Item is private;
   Size: Positive := 64;
package Stack is
   procedure Push(X: Item);
   procedure Put;
   
   function Pop return Item;
   function Length return Integer;
end Stack;

Stack Body (stack.adb)

with Ada.Text_IO; use Ada.Text_IO;

package body Stack is
   Stack: array(1 .. Size) of Item;
   Top  : Integer range 0 .. Size := 0;
   
   function Length return Integer is (Top);
   
   procedure Push(X: Item) is
   begin
      Top := Top + 1;
      Stack(Top) := X;
   end Push;

   function Pop return Item is
   begin
      Top := Top - 1;
      return Stack(Top + 1);
   end Pop;
   
   procedure Put is
      Count: String := Integer'Image(Top);
   begin
      Put("Stack (" & Count(Count'First + 1 .. Count'Last) & "):");
      for I in 1 .. Top loop
         Put(Item'Image(Stack(I)));
         if I /= Top then
            Put(",");
         end if;
      end loop;
      New_Line;
   end Put;
end Stack;

Stack Test (test.adb)

with Ada.Text_IO; use Ada.Text_IO;
with Stack;

procedure Test is
   package S1 is new Colors(Integer);
   package S2 is new Colors(Float);
    
   Unused: Integer;
begin
   S1.Put;
   S1.Push(7);
   S1.Push(5);
   S1.Push(3);
   S1.Put;

   Unused := S1.Pop;
   Put_Line("Stack length is:" & Integer'Image(S1.Length));
   Unused := S1.Pop;
   S1.Put;

   Put_Line("The second stack is a distinct object:");
   S2.Put;
   S2.Push(0.5);
   S2.Push(1.5);
   S2.Put;
end Test;

-- Stack (0):
-- Stack (3): 7, 5, 3
-- Stack length is: 2
-- Stack (1): 7
-- The second stack is a distinct object:
-- Stack (0):
-- Stack (2): 5.00000E-01, 1.50000E+00

Object Orientation

Inheritance with Abstract Subprograms

with Ada.Numerics; use Ada.Numerics;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;

declare
   type Shape is tagged record
      X, Y: Float;
   end record;

   function Area(Obj: Shape) return Float is abstract;
   function Distance(Obj: Shape) return Float;
   -- ...
   function Distance(Obj: Shape) return Float is
      (Sqrt(Obj.X*Obj.X + Obj.Y*Obj.Y));

   -- -------------------------------------------------

   type Circle is new Shape with record
      Radius: Float;
   end record;

   function Area(C: Circle) return Float;
   -- ...
   function Area(C: Circle) return Float is
      (Pi*C.Radius*C.Radius);

   -- -------------------------------------------------

   type Rectangle is new Shape with record
      W, H: Float;
   end record;

   function Area(Rect: Rectangle) return Float;
   -- ...
   function Area(Rect: Rectangle) return Float is
      (Rect.W*Rect.H);

   -- -------------------------------------------------
   
   S: Shape := (1.0, 2.0);
   C: Circle := (2.5, 2.5, 1.0);
   R: Rectangle := (5.0, 5.0, 2.0, 3.0);
begin
   Put_Line(Float'Image(S.X) & "," & Float'Image(S.Y));
   Put_Line(Float'Image(C.X) & "," & Float'Image(C.Y) & "," &
            Float'Image(C.Radius));
   Put_Line(Float'Image(R.X) & "," & Float'Image(R.Y) & "," &
            Float'Image(R.W) & "," & Float'Image(R.H));
end;

Controlled Types

with Ada.Finalization; use Ada.Finalization;

declare
   type T is new Controlled with record
      Name: String(1..1);
      Val : Integer;
   end record;

   overriding procedure Initialize(X: in out T);
   overriding procedure Adjust(X: in out T);
   overriding procedure Finalize(X: in out T);

   procedure Initialize(X: in out T) is
   begin
      Put_Line("Initializing '" & X.Name & "' with" & Integer'Image(X.Val));
   end Initialize;

   procedure Adjust(X: in out T) is
   begin
      Put_Line("Adjusting '" & X.Name & "' with" & Integer'Image(X.Val));
   end Adjust;

   procedure Finalize(X: in out T) is
   begin
      Put_Line("Finalizing '" & X.Name & "' with" & Integer'Image(X.Val));
   end Finalize;

   X: T := (Controlled with Name => "X", Val => 5); -- 1
   Y: T;                                            -- 2
begin
   Y := (Controlled with Name => "Y", Val => 7);    -- 3
   X := Y;                                          -- 4
end;                                                -- 5

Output

[2] Initializing ' ' with 0
[2] Finalizing ' ' with 0
[3] Adjusting 'Y' with 7
[4] Finalizing 'Y' with 7
[4] Finalizing 'X' with 5
[4] Adjusting 'Y' with 7
[5] Finalizing 'Y' with 7
[5] Finalizing 'Y' with 7

Memory Management

A Simple Access Type

1. Allocates a dynamic array of 20 integers.
2. Assigns the array values to the square of their index.
3. Prints the values out.
4. Frees the memory.

with Ada.Unchecked_Deallocation;

declare
   type Int_Array is array (Positive range <>) of Integer;
   type Int_Array_Access is access Int_Array;

   procedure Free is new Ada.Unchecked_Deallocation(Object => Int_Array, Name => Int_Array_Access);

   Ints: Int_Array_Access;
begin
   Ints := new Int_Array(1 .. 20);
   for I in Ints'Range loop
      Ints(I) := I*I;
   end loop;

   for I in Ints'Range loop
      Put_Line(Integer'Image(Ints(I)));
   end loop;

   Free(Ints);
end;