Ada

Ada is a very influential language, even if it never gained the popularity it hoped to achieve. It did a lot of things right, and is definitely worth learning.

Overview

Ada is the first internationally standardized object-oriented language (ISO 8652:1995). The language was designed to facilitate the design of large, long-lived, efficient, reliable software systems. You can use it in virtually every interesting area of Computer Science.

Online Resources

The language seems complex because it was designed for complex tasks. Readability was an important design goal. It's actually a great language for writing code because many aspects of good software engineering are enforced by the language.

A First Program

The simplest kind of program is a simple parameterless procedure:

first.adb
------------------------------------------------------------------------------
-- This program writes and sums a sequence of integers.  It illustrates the
-- basic format of a very small Ada program as well as:
--
--   the use of library packages (e.g. Ada.Text_IO)
--   the use of *overloaded* procedures (e.g. Ada.Text_IO.Put)
--   the use of procedures with default parameters (e.g. Ada.Text_IO.New_Line)
--   variable declarations, both with and without initializers
--   assignment statements
--   for-loop statements
--   type conversion
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO, Ada.Float_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO, Ada.Float_Text_IO;

procedure First is

  Number_Of_Values: Integer;           -- variable declaration
  Sum: Integer := 0;                   -- variable declaration w/ initializer

begin
  Put ("Enter an integer: ");          -- put a string
  Get (Number_Of_Values);              -- get an integer
  for I in 1..Number_Of_Values loop    -- note the implicit declaration of I
    Put (I);                           -- put an integer
    Put (',');                         -- put a character
    Sum := Sum + I;
  end loop;                            -- variable I does not exist after loop
  New_Line (2);                        -- call New_Line with an argument
  Put ("The sum is ");                 -- put a string
  Put (Sum);
  New_Line;                            -- call New_Line with default argument
  Put ("The average is ");
  Put (Float(Sum) / Float(Number_Of_Values));
  New_Line;
end First;

To compile, bind, and link:

gnatmake first.adb

This produces the executable file first on a Unix system, or first.exe on a Windows system. (By the way, gnatmake is a script that runs gcc followed by gnatbind followed by gnatlink.)

Language Structure

The Ada language is comprised of the

Reserved Words

abort    begin    elsif     in      others     rem       terminate
abs      body     end       is      out        renames   then
abstract case     entry     limited package    requeue   type
accept   constant exception loop    pragma     return    until
access   declare  entry     mod     private    reverse   use
aliased  delay    for       new     procedure  select    when
all      delta    function  not     protected  separate  while
and      digits   generic   null    raise      subtype   with
array    do       goto      of      range      tagged    xor
at       else     if        or      record     task

Symbols

+      -      *      /      **     &      <
<=     =      /=     >=     >      (      )
|      .      ,      :      ;      :=     <>
>>     <<     =>     ..     '      "      #

Program Structure

An Ada program is made up of a collection of program units, which can be either subprograms or packages. Ada units are designed to have well specified interfaces so they are highly reusable.

Types

In Ada, every object has a type. Types are grouped into classes. There are language-defined types (and classes) and users can define their own types. The language-defined classes form a hierarchy:

adatypes.gif

Statements

null              Block          conditional entry call
assignment(:=)    exit           timed entry call
procedure call    goto           asynchronous transfer of control
if                return         accept
case              raise          selective accept
loop              delay          requeue
while             delay until    abort
for               entry call     code

Standard Library

Ada features a really cool and comprehensive standard library. There are three root library units: Ada, System, and Interfaces.

Ada                               Interfaces
 |_ Characters                      |_ C
  |    |_Handling                   |    |_ Pointers
  |    `_Latin_1                    |    `_ Strings
  |_ Strings                        |_ Fortran
  |    |_ Fixed                     `_ Cobol
  |    |_ Bounded
  |    |_ Unbounded
  |    |_ Maps                    System
  |    |    `_ Constants            |_ Storage_Elements
  |    |_ Wide_Fixed                |_ Storage_Pools
  |    |_ Wide_Bounded              |_ Address_To_Access_Conversions
  |    |_ Wide_Unbounded            |_ Machine_Code
  |    `_ Wide_Maps                 `_ RPC
  |         `_ Wide_Constants
  |_ Numerics
  |    |_ Generic_Elementary_Functions
  |    |_ Elementary_Functions
  |    |_ Generic_Complex_Types
  |    |_ Complex_Types
  |    |_ Generic_Complex_Elementary_Functions
  |    |_ Complex_Elementary_Functions
  |    |_ Discrete_Random
  |    `_ Float_Random
  |_ Decimal
  |_ Exceptions
  |_ Tags
  |_ Finalization
  |_ Task_Finalization
  |_ Task_Attributes
  |_ Synchronous_Task_Control
  |_ Asynchronous_Task_Control
  |_ Dynamic_Priorities
  |_ Real_Time
  |_ Unchecked_Conversion
  |_ Unchecked_Deallocation
  |_ Sequential_IO
  |_ Direct_IO
  |_ Text_IO
  |    |_ Text_Streams
  |    |_ Editing
  |    `_ Complex_IO
  |_ Wide_Text_IO
  |    |_ Text_Streams
  |    |_ Editing
  |    `_ Complex_IO
  |_ Integer_Text_IO
  |_ Float_Text_IO
  |_ Storage_IO
  |_ IO_Exceptions
  |_ Streams
  |    `_ Stream_IO
  |_ Interrupts
  |    `_ Names
  |_ Calendar
  `_ Command_Line

More Programs

Another Simple Application

triple.adb
------------------------------------------------------------------------------
-- triple.adb
--
-- This program writes out a table of all Pythagorean triples  whose elements
-- are in the range 1..100.  Each of the triples are written on a single line
-- of text with each value  right-justified in a text field six characters
-- wide.  The program illustrates:
--
--   the procedure Ada.Text_IO.Put_Line
--   the operator "**"
--   nested loops
--   the width parameter of Ada.Integer_Text_IO.Put
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO;

procedure Triple is
begin
  Put_Line ("     A     B     C");
  Put_Line ("------------------");
  for C in 1 .. 100 loop
    for B in 1 .. C loop
      for A in 1 .. B loop
	if A ** 2 + B ** 2 = C ** 2 then
	  Put (A, 6);
	  Put (B, 6);
	  Put (C, 6);
	  New_Line;
	end if;
      end loop;
    end loop;
  end loop;
end Triple;

Three Prime Number Programs

primes1.adb
------------------------------------------------------------------------------
-- primes1.adb
--
-- This program  computes and prints all prime numbers up to 10000 using an
-- inefficient version of Eratosthenes' method, then it prints how many prime
-- numbers it found.  The program illustrates:
--
--   constant declarations
--   that underscores may appear in integer literals
--   arrays and array aggregates
--   that initializing expressions do not have to be static
--   the 'First and 'Last attribute for arrays
--   nested procedures (note that these are NOT allowed in C and C++)
--   parameters of mode 'in'
--   if statements and while-loop statements
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO;

procedure Primes1 is

  Size  : constant Integer := 10_000;
  Sieve : array (2..Size) of Boolean := (2..Size => True);
  Count : Integer := 0;

  procedure Check_Off_Multiples (P: Integer) is
    K: Integer := P;
  begin
    while K <= Size - P loop                -- while there are more multiples
      K := K + P;                           -- go to next multiple of P
      Sieve(K) := False;                    -- mark it non-prime
    end loop;
  end Check_Off_Multiples;

  procedure Report (Number_Found: Integer) is
  begin
    Put (Number_Found);
    Put_Line (" primes found");
  end Report;

begin
  for I in Sieve'First .. Sieve'Last loop
    if Sieve(I) then
      Check_Off_Multiples (I);
      if Count mod 12 = 0 then              -- write twelve primes per row
	New_Line;
      end if;
      Put (I, 6);                           -- write each in field of 6 chars
      Count := Count + 1;                   -- found another one
    end if;
  end loop;
  New_Line (2);                             -- make space before reporting
  Report (Count);
end Primes1;

primes2.adb
------------------------------------------------------------------------------
-- primes2.adb
--
-- This program computes and prints all the prime numbers up to and including
-- a number which is input  by the user in response to a prompt, and then re-
-- ports how many primes it found.  The program illustrates:
--
--   the predefined subtype Natural
--   type declarations
--   unconstrained array definitions
--   blocks
--   parameter modes (in, out, and in out)
--   named parameter associations (these are great!)
--   the 'Range attribute for arrays
--   the array concatenation operator (&)
--   the 'Image attribute (defined for any discrete type)
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO;

procedure Primes2 is

  Limit    : Natural;                       -- will find primes up to this
  How_Many : Natural := 0;                  -- how many primes were found

  type Check_List is array (Natural range <>) of Boolean;

  procedure Compute_Primes (Up_To: in Natural; Count: in out Natural) is
    Sieve: Check_List(2..Up_To);
  begin
    Sieve := (others => True);
    for I in Sieve'Range loop
      if Sieve(I) then
	Put (Width => 12, Item => I, Base => 10);
	Count := Count + 1;
	declare                             -- start a block
	  K: Natural := I;                  -- variable local to the block
	begin
	  while K <= Sieve'Last - I loop
	    K := K + I;                     -- go to next multiple
	    Sieve(K) := False;              -- check off this multiple
	  end loop;
	end;                                -- after block, K does not exist
	if Count mod 6 = 0 then             -- write six primes per row
	  New_Line;
	end if;
      end if;
    end loop;
    New_Line (2);
  end Compute_Primes;

begin
  Put ("Find primes up to what number? ");
  Get (Limit);
  Compute_Primes (Up_To => Limit, Count => How_Many);
  Put_Line ("I found" & Natural'Image(How_Many) & " primes.");
end Primes2;

primes3.adb
------------------------------------------------------------------------------
-- primes3.adb
--
-- This program computes and prints all the prime numbers up to and including
-- a number which is provided as the sole argument on the command line, or, if
-- no command  line arguments are  given, input  by the user in response  to a
-- prompt, and then reports how many primes it found. The program illustrates:
--
--   the predefined package Ada.Command_Line
--   the 'Value attribute for converting strings to natural numbers
--   handling an exception (in this case a built in one)
--   how not using a use clause can make code a bit more readable
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO, Ada.Command_Line;
use Ada.Text_IO, Ada.Integer_Text_IO, Ada;

procedure Primes3 is

  Limit    : Natural;                       -- will find primes up to this
  How_Many : Natural;                       -- how many primes were found

  procedure Compute_Primes (Up_To: in Natural; Count: out Natural) is
    Sieve: array (2 .. Up_To) of Boolean := (others => True);
  begin
    Count := 0;
    for I in Sieve'Range loop
      if Sieve(I) then
	Put (Item => I, Width => 12, Base => 10);
	Count := Count + 1;
	declare                           -- start a block
	  K: Natural := I;                -- variable local to the block
	begin
	  while K <= Sieve'Last - I loop
	    K := K + I;                   -- go to next multiple
	    Sieve(K) := False;            -- check off this multiple
	  end loop;
	end;                              -- after the block K does not exist
	if Count mod 6 = 0 then           -- write six primes per row
	  New_Line;
	end if;
      end if;
    end loop;
    New_Line (2);
  end Compute_Primes;

begin
  if Command_Line.Argument_Count = 0 then
    Put ("Find primes up to what number? ");
    Get (Limit);
  else
    Limit := Natural'Value(Command_Line.Argument(1));
  end if;
  Compute_Primes (Up_To => Limit, Count => How_Many);
  Put_Line ("I found" & Natural'Image(How_Many) & " primes.");
exception
  when Data_Error => Put_Line ("I do not understand your input");
end Primes3;

Understanding Types

types.adb
------------------------------------------------------------------------------
-- types.adb
--
-- This program  doesn't *do* anything  useful; it just illustrates types and
-- objects in Ada.  Among the features illustrated are:
--
--   array, record, and pointer declarations
--   incomplete declarations (to allow for recursive types)
--   array and record aggregates
--   default values on record fields
--   discriminants on records
--   strings (the type Standard.String - not one the fancy string types)
--   use of access values (a.k.a. "pointers")
--   enumerations containing characters
--   separation of subprogram specifications from bodies
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO, Ada.Float_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO, Ada.Float_Text_IO;

procedure Types is

  -- Simple object declarations:

  Sorted: Boolean;                          -- variable declaration
  Count: Integer := 0;                      -- vars MAY have initializers
  Pi: constant Float:= 3.1415926535897932;  -- consts MUST have initializers
  Two_Pi: constant Float := 2.0 * Pi;       -- expressions allowed
  K: constant Integer := 2 ** 10;           -- 1K = 1024

  -- Simple type declarations: constrained arrays, enumeration types,
  -- user defined subtypes.

  type Table is array (1..10) of Integer;

  type Color is (Black, Blue, Green, Cyan, Red, Magenta, Yellow, White);
  subtype Reddish is Color range Red..Yellow;
  type Color_Chart is array (0..K-1) of Color;

  type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
  subtype Weekday is Day range Mon..Fri;
  type Time_Card is array (Day) of Float;
  type Union_Time_Card is array (Weekday) of Float;

  -- Unconstrained array type declarations are just fine.  They MAY be
  -- constrained in a subtype declaration; they MUST be constrained in
  -- an object declaration.

  type Matrix is array (Integer range <>, Integer range <>) of Float;
  subtype Mat_33 is Matrix (1..3, 1..3);

  Grid  : Matrix (1..8, 1..8);
  Ident : constant Mat_33 := ((1.0,0.0,0.0),(0.0,1.0,0.0),(0.0,0.0,1.0));

  -- When declaring a subtype, you do not have to specify a range
  -- constraint:

  subtype Int is Integer;

  -- Enumeration types may contain identifiers or character literals.

  type Roman_Digit is ('I', 'V', 'X', 'L', 'C', 'D', 'M');
  type Roman is array (Positive range <>) of Roman_Digit;

  -- The following are predefined (i.e. they appear in package Standard):
  --
  -- subtype Positive is Integer range 1..Integer'Last
  -- type String is array (Positive range <>) of Character;
  --
  -- Examples of arrays whose elements are character literals follow.  Note
  -- the convenient shorthand notation for specify array aggregates of
  -- these types.

  Prompt: String(1..50);
  Greeting: constant String(1..5) := "Hello";
  subtype Line is String(1..80);
  C_Comment: Line := (1 => '/', 2..79 => '*', 80 => '/');
  Ninety_Six: constant Roman := "XCVI";

  -- Subprograms (procedures and functions) can be declared before their
  -- body is given.

  function Middle_Character (S: String) return Character;

  -- Another enumeration type:

  type Month_Name is (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);

  -- Here are some examples of record types:

  type Date is record
    Day: Positive range 1..31;
    Month: Month_Name;
    Year: Integer;
  end record;

  type Complex is record
    Re: Float := 0.0;                       -- fields may have initial values
    Im: Float := 0.0;
  end record;

  -- The following is an example of a record type with a discriminant.
  -- An object S of type Square has two attributes: S.Side and S.Data.
  -- The discriminant Side must be given a value when the object is
  -- declared and is read only.

  type Square (Side: Integer) is record
    Data: Matrix(1..Side, 1..Side);
  end record;

  subtype Three_D_Xform is Square(4);
  A_Funny_Thing: Square(2) := (2, ((1.0, 3.2), (9.9, 3.44E-26)));

  -- You can specify a default for the discriminant:

  type Buffer (Size: Positive := 256) is record
    Position: Positive;
    Value: String(1..Size);
  end record;

  -- If a value is specified for an object of a record type with a default
  -- discriminant, then it is a normal constrained object...

  K_Buffer: Buffer(1024);                   -- 1024 elements

  -- ...but if no value is specified, the object is unconstrained (i.e.
  -- you can actually change the discriminant at run time (provided
  -- assignments are made to all fields simultaneously).

  My_Buffer: Buffer;                        -- 256 elements but changeable

  -- Arbitrary linked structures require mutually recursive types.  Since
  -- Ada elaborates declarations strictly in order some types must be
  -- declared before they are defined.

  type Node;                                -- incomplete type declaration
  type Link is access Node;                 -- use of incomplete declaration

  type Node is record                       -- completion
    Value: Integer;
    Previous: Link;
    Next: Link;
  end record;

  type Gender is (Male, Female);
  type Person (Sex: Gender);                -- incomplete
  type Car;                                 -- incomplete

  type Person_Pointer is access Person;
  type Woman_Pointer is access Person(Female);
  type Man_Pointer is access Person(Female);
  type Car_Pointer is access Car;

  type Car is record
    VID: String(1..25);
    Primary_Owner: Person_Pointer;
  end record;

  -- Here is an example of a record with a variant part.  The variant
  -- is controlled by the discriminant.  Variant records are technically
  -- unnecessary in Ada because type extension is a far superior way to
  -- do what variant records to; however, type extension did not exist
  -- in pre-1995 Ada.  So you might see variant records from time to
  -- time....

  type Person (Sex: Gender) is record
    Name: String(1..30);
    Birthday: Date;
    Weight: Float;
    Favorite_Car: Car_Pointer;
    case Sex is
      when Male => Wife: Woman_Pointer;
      when Female => Husband: Man_Pointer;
    end case;
  end record;

  -- Here are some more variable declarations:

  T: Time_Card;
  D: Date;
  P1: Person_Pointer;
  P2: Person_Pointer;
  C: Car_Pointer;
  Lut: Color_Chart;
  Z: Complex;
  S: Link;
  Q: Person(Female);

  -- Here is the body of the function Middle_Character that we gave the
  -- specification for a while back.  Note that the respecification of
  -- the header must match the previous declaration in terms of the
  -- number, names, modes and types of its parameters, and if a function,
  -- in terms of its return type as well.

  function Middle_Character (S: String) return Character is
  begin
    return S((S'First + S'Last)/2);
  end Middle_Character;

begin
  Put (Two_Pi, Exp => 0);
  New_Line;
  Put (Two_Pi, Fore => 7, Aft => 6, Exp => 5);
  New_Line;
  T := (2.6, 10.2, 9.3, 8.0, 0.0, 0.0, 1.0);
  Lut := (Black, Cyan, Red, Red, others => Magenta);
  D := (1, Jul, 1991);
  D := (Month => Jul, Day => 1, Year => 1991);
  D := (1, Year => 1991, Month => Jul);
  Put (D.Year);
  New_Line;
  Put (Greeting);
  New_Line;
  Put (C_Comment(68..80));                  -- this is called a slice
  New_Line;
  Z.Re := 6.72;
  Z := (3.0, -234.22);
  C := new Car;
  P1 := new Person(Female);
  P1.Name := "Mary                          ";
  P2 := new Person(Male);
  P1.Favorite_Car := C;
  C.Primary_Owner := P2;
  S := new Node;
  S.all.Value := 3;
  S.Value := 3;                             -- ".all" is optional in middle
  S.Next := new Node'(Value => 10, Next => null, Previous => S);
  P2.Birthday.Year := 1967;
end Types;

Fibonacci Numbers

fib.adb
------------------------------------------------------------------------------
-- fib.adb
--
-- This program prints out Fibonacci numbers in octal, decimal and hexidecimal
-- in reverse order.  The number  of Fibonacci  numbers that the user wants
-- to  see is input on the command line, but if no arguments are given on the
-- command line then the program will prompt the user to input that value.
-- Features illustrated:
--
--   defining your own exceptions
--   enumerated types
--   the 'Pos attribute
--   reverse keyword in for loop range
--   the case statement
--   deep nesting of procedures
--   assignment to array slices
--   lots of useless mixing of positional and named associations.
------------------------------------------------------------------------------

with Ada.Text_IO, Ada.Integer_Text_IO, Ada.Command_Line;
use Ada.Text_IO, Ada.Integer_Text_IO, Ada.Command_Line;

procedure Fib is

  Number_Of_Values_Requested: Integer;

  -- In Ada there are a number of predefined exceptions, but we can declare
  -- our own.  Too_Few will be raised if the user does not ask for at least
  -- two Fibonacci numbers, and Bad_Argument will be raised if the program
  -- can not make sense out of the user's input:

  Too_Few, Bad_Argument: exception;

  type Number_List is array (Integer range <>) of Integer;
  type Number_System is (Octal, Decimal, Hexidecimal);

  -- String_To_Natural (S) returns the natural number corresponding to
  -- the string S.  If S contains characters that are not digits, the
  -- exception Bad_Argument is raised; if the string represents a
  -- number larger than the system can represent, Constraint_Error
  -- is raised.  Note that this function could more easily have been
  -- written as "return Natural'(Natural'Value(S));".  In that case
  -- the exception Data_Error would be raised if the string contained
  -- non-digit characters.

  function String_To_Natural (S: String) return Natural is
    Result: Integer := 0;
  begin
    for I in S'Range loop
      if S(I) not in '0'..'9' then
	raise Bad_Argument;
      end if;
      Result := 10 * Result + (Character'Pos(S(I)) - Character'Pos('0'));
    end loop;
    return Result;
  end String_To_Natural;

  -- The function Get_User_Input returns the user's "input" as follows:
  -- First it checks to see if any argument was entered on the command
  -- line and if so attempts to convert that value to a natural number.
  -- If the command line has no parameters the user is prompted for an
  -- input.  In either case, the value input must be greater than or
  -- equal to 2; the function raises Too_Few if it is not.

  function Get_User_Input return Integer is
    Size: Integer;
  begin
    if Argument_Count > 0 then                   -- an argument was supplied
      Size := String_To_Natural(Argument(1));    -- use the first argument
    else
      Put ("How many numbers do you want (minimum = 2)? ");
      Get (Size);
    end if;
    if Size < 2 then
      raise Too_Few;
    end if;
    return Size;
  end Get_User_Input;

  -- Compute (Size) finds and displays the first Size Fibonacci numbers.
  -- It first allocates an array of just the right size to store the
  -- numbers, then loads the array by performing the straightforward
  -- calculations.  Then the array is printed backwards three times
  -- with different bases, using the helper function Display.

  procedure Compute (Size: in integer) is
    Fibs: Number_List(1..Size);

    procedure Display (B: Number_System) is
    begin
      Put ("Fibonacci Numbers in " & Number_System'Image(B) & " backwards: ");
      New_Line (2);
      for I in reverse Fibs'Range loop
	case B is
	  when Octal => Put (Fibs(I), Base => 8, Width => 20);
	  when Decimal => Put (Fibs(I), 16, 10);
	  when Hexidecimal => Put (Base => 16, Item => Fibs(I), Width => 20);
	end case;
      end loop;
      New_Line (2);
    end Display;

  begin
    Fibs(1..2) := (1,1);                         -- load the first two values
    for I in 3..Size loop
      Fibs(I) := Fibs(I - 1) + Fibs(I - 2);
    end loop;
    Display (Octal);
    Display (Decimal);
    Display (Hexidecimal);
  end Compute;

begin
  Number_Of_Values_Requested := Get_User_Input;
  Compute (Size => Number_Of_Values_Requested);
  Put_Line ("Program successfully completed");
exception
  when Too_Few => Put_Line ("Not enough values requested");
  when Bad_Argument => Put_Line ("Illegal command line argument");
  when Constraint_Error => Put_Line ("I can't find that many");
  when Data_Error => Put_Line ("That's not a decent response");
end Fib;

A Large Example

Here we'll make an abstract data type for stacks, using linked lists. We'll see generics, separate compilation, and child packages.

First we start with the package specification

unbounded_stacks.ads
------------------------------------------------------------------------------
-- unbounded_stacks.ads
--
-- A generic package for unbounded LIFO stacks.  It exports a limited private
-- type 'Stack'.
--
-- Generic Parameters:
--
--   Element        the desired type of the stack elements.
--
-- Operations:
--
--   Is_Empty (S)   whether or not S is empty.
--   Is_Full (S)    whether or not S is full.
--   Size (S)       the number of elements in S.
--   Push (S, E)    push E on  top of S.  Raise  Overflow if there  is no room
--                  available in S.
--   Top (S)        the top element  of S.  Raise  No_Top  if there  is no top
--                  element.
--   Pop (S)        remove the top element of S.  Raise Underflow if S is ini-
--                  tially empty since no element can be popped.
--   Pop (S, E)     remove the element from the top of  S and  assign it to E.
--                  Raise Underflow if S  is initially empty  since no element
--                  can be popped.
------------------------------------------------------------------------------

with Ada.Text_IO;
use Ada.Text_IO;

generic
  type Element is private;
package Unbounded_Stacks is

  type Stack is limited private;

  Overflow, Underflow, No_Top: exception;

  function Is_Empty (S: Stack) return Boolean;
  function Size (S: Stack) return Natural;
  procedure Push (S: in out Stack; E: Element);
  function Top (S: Stack) return Element;
  procedure Pop (S: in out Stack);
  procedure Pop (S: in out Stack; E: out Element);

private

  type Node;
  type Stack is access Node;
  type Node is record
    Data : Element;
    Link : Stack;
  end record;

end Unbounded_Stacks;

The implementation of this package spec appears in a separate file:

unbounded_stacks.adb
------------------------------------------------------------------------------
-- unbounded_stacks.adb
--
-- Implementation of the unbounded stack ADT.
------------------------------------------------------------------------------

package body Unbounded_Stacks is

  function Is_Empty (S: Stack) return Boolean is
  begin
    return S = null;
  end Is_Empty;

  function Size (S: Stack) return Natural is
  begin
    if S = null then
      return 0;
    else
      return 1 + Size(S.Link);
    end if;
  end Size;

  procedure Push (S: in out Stack; E: Element) is
  begin
    S := new Node'(E, S);
  exception
    when Storage_Error => raise Overflow;
  end Push;

  function Top (S: Stack) return Element is
  begin
    if Is_Empty (S) then
      raise No_Top;
    end if;
    return S.Data;
  end Top;

  procedure Pop (S: in out Stack) is
  begin
    if Is_Empty (S) then
      raise Underflow;
    end if;
    S := S.Link;
  end Pop;

  procedure Pop (S: in out Stack; E: out Element) is
  begin
    if Is_Empty (S) then
      raise Underflow;
    end if;
    E := S.Data;
    S := S.Link;
  end Pop;

end Unbounded_Stacks;

Suppose we wanted to add I/O capability to our stacks. In Ada, you can put this additional functionality in a child package. It's a good idea not to put I/O in the basic stack package since that pollutes the original package with funcitonality that not everyone would want. Here is the spec:

unbounded_stacks-io.ads
------------------------------------------------------------------------------
-- unbounded_stacks-io.ads
--
-- A generic child package which enables output for unbounded stacks.
--
-- Generic Parameters:
--
--   Put (F, E)     procedure to display element E to file F.
--
-- Operations:
--
--   Put (F, S)     write S to file F in the form  <x1 x2 ... xn>  FROM TOP TO 
--                  BOTTOM.
--   Put (S)        Same as Put (Current_Output, S)
------------------------------------------------------------------------------

with Ada.Text_IO;
use Ada.Text_IO;

generic
  with procedure Put (F: File_Type; E: Element);
package Unbounded_Stacks.IO is

  procedure Put (F: File_Type; S: Stack);
  procedure Put (S: Stack);

end Unbounded_Stacks.IO;

...and the body

unbounded_stacks-io.adb
------------------------------------------------------------------------------
-- unbounded_stacks-io.adb
--
-- Implementation of the unbounded stack ADT ouput routines.
------------------------------------------------------------------------------

package body Unbounded_Stacks.IO is

  procedure Put (F: File_Type; S: Stack) is
    T: Stack := S;
  begin
    Put (F, "< ");
    while T /= null loop
      Put (F, T.Data);
      Put (' ');
      T := T.Link;
    end loop;
    Put (F, '>');
  end Put;

  procedure Put (S: Stack) is
  begin
    Put (Current_Output, S);
  end Put;

end Unbounded_Stacks.IO;

To exercise the stack package, we write a little driver:

test_unbounded_stacks.adb
------------------------------------------------------------------------------
-- test_unbounded_stacks.adb
--
-- A program that tests the unbounded stack ADT package.
------------------------------------------------------------------------------

with Ada.Text_IO, Unbounded_Stacks, Unbounded_Stacks.IO;
use Ada.Text_IO;

procedure Test_Unbounded_Stacks is

  package My_Stacks is new Unbounded_Stacks (Character);
  use My_Stacks;

  package My_Stacks_IO is new My_Stacks.IO (Put);
  use My_Stacks_IO;

  S: Stack;

  procedure Test is
    Option: Character;
    Data: Character;
  begin
    loop
      Put (S);
      Put_Line (" Length =" & Integer'Image(Size(S)));
      Put ("Empty pusH Pop Quit: ");
      Get (Option);
      New_Line;
      case Option is
        when 'h' =>
          begin
            Put ("push what? "); Get (Data); Push (S, Data);
          exception
            when Overflow => Put_Line ("Cannot push onto full stack");
          end;
        when 'p' =>
          begin
            Pop (S, Data); Put (Data); Put_Line (" popped");
          exception
            when Underflow => Put_Line ("Cannot pop from empty stack");
          end;
        when 'e' =>
          if Is_Empty(S) then Put ("Empty");
          else Put ("Not Empty");
          end if;
        when 'q' => exit;
        when others => null;
      end case;
      New_Line;
    end loop;
  end Test;

begin
  Test;
end Test_Unbounded_Stacks;

To compile, bind, and link, just enter

gnatmake test_unbounded_stacks.adb

and you have your executable. This is because gnatmake automatically searches out all dependencies and compiles out of date files when needed (assuming that subprogram and package names are the same as the filename in which they are contained.

Even More Examples

If you like concurrent programming, you might find this page interesting.