11 Advanced Ada Programming

11.1 Packages

Large Ada programs are divided up into packages. These are collections of procedures, functions, variables and other declarations that serve a similar purpose. You can have packages to draw text on the screen, or packages to do accounts payable, or package to work with complex numbers.

To make it easier for different people to work on different packages, and to make packages self-documenting, Ada packages are divided into two parts. The package specification (or package spec) contains everything that other programs need to use your package. It contains all variables they can access, all the subprograms they can call, etc. For subprograms, you only use the subprogram header, the procedure or function line, to let the programmers know the name of the subprogram and what the parameters are.

package Currency is

-- This package defines US and Canadian dollars, and converts money between
-- these two countries.

subtype aMoney is float;

type USDollars is new aMoney;

type CanadianDollars is new aMoney;

-- aMoney is separate so we can change the base type, if necessary, for
-- US and Canadian dollars. USDollars and Canadian dollars deliberately
-- incompatible because it could be messy if we mix them up

procedure SetExchangeRates( USToCanadian, CanadianToUS : float );

function ToCanada( money : USDollars ) return CanadianDollars;

function ToUS( money : CanadianDollars ) return USDollars;

-- Set the exchange rate between US and Canada, and two functions to
-- convert between currencies.

end Currency;

In GNAT, you must save this package under the filename "currency.ads" (.ads for Ada Spec ). Here we create different money values two functions to convert between the different rates and a procedure to set the exchange rates to use in the functions. Notice there is no main program.

With the spec complete, you can compile it to check for errors. If you don't intend to complete the package soon, you can mark the subprograms as incomplete using pragma import( stubbed, subprogram_name ) This will allow you to use the package in a program and any call to the unfinished subprograms will result in an error.

To complete the package, we create a package body with the rest of the details, including the completed subprograms. With the implementation details hidden in the package body, other programmers don't have to worry about how currency is actually handled.

package body Currency  is

-- This package defines US and Canadian dollars, and converts money between
-- these two countries.

USToCanadaExchangeRate : float;
CanadaToUSExchangeRate : float;

procedure SetExchangeRates( USToCanadian, CanadianToUS : float ) is
begin
  USTOCanadaExchangeRate := USToCanadian;
  CanadaToUSExchangeRate := CanadianToUS;
end SetExchangeRates;

function ToCanada( money : USDollars ) return CanadianDollars is
begin
  return CanadianDollars( money * USToCanadaExchangeRate );
end ToCanada;

function ToUS( money : CanadianDollars ) return USDollars is
begin
  return USDollars( money * CanadaToUSExchangeRate );
end ToUS;

-- Set the exchange rate between US and Canada, and two functions to
-- convert between currencies.

end Currency;

Notice we have access to everything we defined in the package spec--we don't need to repeat anything in the body.

Because the two exchange rate variables are defined inside the package body, they are invisible to other programmers.

Save this package body as "currency.adb" (.adb for AdaBody). Make sure all pragma import( Stubbed,'s are removed for the finished subprograms. Compile both and you have a working package.

To use your package in a program, use the with statement.

with text_io, currency;
procedure currencyTest is
begin
  Currency.SetExchangeRate( 1.5, 0.7 );
  Text_IO.Put_Line( "1 Canadian dollar is " & Currency.ToUS( 1.0 )'img );
end currencyTest;

To have Ada check which package a subprogram belongs to, and avoid typing the package name constantly, use the use statement.

with currency;
use currency;
...
SetExchangeRate( 1.5, 0.7 );

If the use statement creates an ambiguity, Ada will warn you that it can't determine which package SetExchangeRate is in.

Package bodies may have main programs, a block at the end of all declarations marked with begin. This allows you to setup your package before it's actually used. In this case, we don't need one.

Package specs may have private sections at the end of the spec. There will be times when you will have to provide information so that Ada can compile your spec, but you don't want the application programmer to be able use this information. For example, you might create a package to maintain a customer list, but you don't want the programmer to access the internal fields of a customer list since you might change them at some point.

Just about anything in a package spec can be marked private, and the compiler expects the details to be specified in the private section. Declarations can also be limited private, meaning that besides having the details inaccessible to the programmer, the programmer can't assign between variables of the type. For example, use limited private if you think you may include pointers in the type at some time in the future.

package CustomerList  is

  type aCustomerNumber is new positive range 1..1000;
  type aCustomerList is limited private;

private

  type aCustomerArray is array( aCustomerNumber ) of string(1..120);

    type aCustomerList is record
      CurrentCustomer : aCustomerNumber;
      Customers : aCustomerArray;
    end record;

  -- no pointers yet, but we may some day, so it's limited private
  end CustomerList;

In this example, a programmer can declare customer lists, but he cannot access the fields CurrentCustomer or Customers (because it's private), nor can he copy lists with assignment statements (because it's limited private).

Packages can have children. A child package is a package that extends the capabilities of the parent package. You can use child packages to add features to existing packages, such as the standard Ada libraries, or to break up large packages into groups of related functions.

Suppose you had a package called accounting that contains tools to handle accounting in general. You can create a child package for accounts payable begins like this:

  package Accouting.Accounts_Payable is

In GNAT, save this package spec as "accounting-accounts_payable.ads", with a minus sign instead of a period.

A child package inherits the package spec from it's parent package. You can access anything in the accounting package, including anything private to which access is normally denied.

When a program uses the statement

  with Accouting.Accounts_Payable;

the parent package, accounting, is automatically with'ed as well (although you still have to use separate use's).
 

11.2 Controlling Elaboration

Elaboration is the initialization of a package that's done before the main program of the package is executed. Assigning values to constants, for example, is elaboration.

For most projects, gnat will work out a good elaboration order on its own. However, large projects with packages referring to each other in complicated ways may require complex elaboration orders. gnat searches every possible elaboration order until it finds one that solves any ambiguities. To speed up projects with slow elaboration times, Ada and gnat provide a number of pragmas to give the compiler hints on the best compilation order and to solve any potential ambiguities.

11.2.1 First line of defense: Pure, Preelaborate and No_Elaboration_Code

Pragma Pure and Preelaborate are elaboration restrictions. They are hints to the Ada compiler to cut down the compiler's work when trying to solve elaboration order. Pragma Pure tells Ada that the package requires no elaboration and contains no executables. For example, a package of nothing but type declarations (with no default values) is pure.

package money_types is
  pragma pure;

  -- a simple package, nothing to elaborate

  subtype aCurrency is float;
  type aSalary is new aCurrency;

end money_types;

Pragma Preelaborate tells Ada that the package requires minimal elaboration. You should try pragma pure, and if it fails, try pragma preelaborate.

gnat 3.11 introduced the gnat specific pragma No_Elaboration_Code. Sometimes this will work when Preelaborate will not.

Sometimes you can declare a function as pure using pragma Pure_Funciton. A pure function is one with no side effects and one that's value doesn't change when executed with the same parameters each time. If the only thing standing in your way to using pure or preelaborate are some functions used to assign initial values, try declaring them as pure functions.

If your package or program fails to meet the elaboration restriction requirements, the compiler will issue an error.

11.2.2 Second line of defense: Elaborate, Elaborate_Body, Elaborate_All

Sometimes the hints are not enough. For example, a package that assigns a value to constant using a function like

  Sin45 : float := Ada.Numerics.Elementary_Functions.Sin( 45, 360 );

is neither pure nor preelaborate because a function must be called when the package is initialized. In these cases, you can tell Ada specifically which package should be elaborated first.

Pragma Elaborate( package ) tells Ada the specified package should be elaborated first. For example, all generics must be elaborated before they are used, so it's a good idea to use pragma elaborate on every generic package.

with generic_linked_list;
pragma Elaborate( generic_linked_list );

Pragma Elaborate_All indicates that a particular package and all the packages used by that package must be elaborate before the current package. For example, if package userio uses package common,

with userio;
pragma Elaborate_All( userio );

will elaborate both userio and common prior to this package

Because Elaborate_All will affect multiple packages, it can cause unnecessary binding errors when used indiscriminately. This pragma, when used everywhere, effectively requires all packages to be arranged in a strict hierarchy. Make sure this is the effect you want.

11.2.3 Other Elaboration Pragmas

Another pragma, pragma Elaborate_Body, forces the package body to be elaborated before the package specification. This is especially useful in generic packages.

Pragma Elaborate and Elaborate_All can also be used to resolve ambiguous elaborations.

11.3 Objects

An object in Ada is known as a tagged record. That is, it is a normal Ada record that has an invisible tag attached to it. The record

type anEmployeeProfile is record
  name : string(1..80);
  age : anAge;
end record;

can be changed to a tagged record by adding the keyword tagged:

type anEmployeeProfile is tagged record
  name : string(1..80);
  age : anAge;
end record;

Although these two records look the same, if we use the 'size attribute to see how much memory the records take up, we'll see that the tagged record is bigger. The extra space is used to store the invisible tag.

Unlike normal records, fields can be added tagged record and a new tagged record can be created. This is called extending the record. To create a related record with additional fields, we use the keyword new:

type anHourlyEmployee is new anEmployeeProfile with record
  hourlyRate : float;
end record;

A tagged record extended in this way has all the fields of anEmployeeProfile, but has the additional field of hourlyRate. anEmployeeProfile and anHourlyEmployee are said to be in the anEmployeeProfile class: the class is the collection of anEmployeeProfile and all record extended from it.

Now we can create a access type (commonly called a pointer, though technically it isn't a pointer) to any record in the class:

type anEmployeeProfilePtr is access all anEmployeeProfile'class;

This pointer can be assigned either anEmployeeProfile record or anHourlyEmployee record. This is the purpose of the tagged record's invisible tag. The tag indicates the type of tagged record a pointer points to since these kinds of pointers can refer to more than one type of tagged record. This is sometimes called late binding.

ptr1 : anEmployeeProfilePtr := new anEmployeeProfile( "Bob Smith", 45 );
ptr2 : anEmployeeProfilePtr := new anHourlyEmployee( "Denise Jones", 37, 17.50 );

Access variables are null until assigned a different value. They are the only variables in Ada to have a default value.

There may be cases where you want to extend a type without adding new fields. Ada provides a shorthand phrase for this. For example, if you want to distinguish hourly employees that work at night as being separate from other hourly employees, use

type aNightHourlyEmployee is new anHourlyEmployee with null record;

In complex classes, there will be times when you'll want to define a record that you never intend to assign variables to. For example, anEmployeeProfile doesn't contain enough fields to completely describe any employee: only the tagged records derived from anEmployeeProfile are usable. When particular record exists only to be extended it called an abstract record. You declare abstract records with the keyword abstract:

type anEmployeeProfile is abstract tagged record
  name : string(1..80);
  age : anAge;
end record;

If you try to create anEmployeeProfile record, Ada will report an error since you said that this record can only be extended into other records.

Ada requires that subprograms that work with tagged records be declared immediately after the type declaration. Each procedure or function can only take one tagged record as a parameter.

type aSalaryEmployee is new anEmployeeProfile with record
  salaryRate : float;
end record;

procedure SetSalaryRate( s : in out aSalaryEmployee'class; rate : float ) is
begin
  s.salaryRate := rate;
end SetSalaryRate;

function GetSalaryRate( s : aSalaryEmployee'class ) return float is
begin
  return s.salaryRate;
end GetSalaryRate;

We've declared two one line subprograms that will work on any tagged record derived from aSalaryEmployee.

Subprograms can be marked as unusable in the same way as abstract tagged records. An abstract procedure or function is a placeholder. Declaring one requires that all types extended from this type must have this subprogram defined. If any do not have this subprogram, Ada will report an error. For example, if anEmployeeProfile had a procedure like

procedure WriteEmployeeName( e : anEmployeeProfile ) is abstract;

all employee profile records would be required to have a procedure called WriteEmployeeName. ASalaryEmployee will have a compilation error unless we add such a function:

procedure WriteEmployeeName( e : aSalaryEmployee )is
begin
  Text_IO.Put_Line( "Employee Name: " & e.Name );
end WriteEmployeename;

WriteEmployeeName could also use aSalaryEmployee'class to refer aSalaryEmployee or any records we extend from it.

To avoid ambiguity, only one tagged record subprogram can refer to any one type. This is different from some other object oriented languages where you can override a classwide subprogram with one that refers to a specific type. The advantage of no overriding is that someone reading your class knows exactly which subprogram will be used for a particular tagged record type--they don't need to read the entire class to make sure the subprogram isn't overridden later on. The disadvantage is that if you can't use a classwide type, you'll have to write subprograms for each and every type in that class. In these cases, typecasting is useful.

Tagged record types can be typecast as other tagged record types (in the same class) using typecasting. You need to do this if you want a dispatching call inside of a dispatching call. For example, if anEmployeeProfile has a GetSalaryRate function, we could call it by:

procedure WriteEmployeeSalary( e : aSalaryEmployee'class ) is
begin
  Text_IO.Put_Line( "The salary is" & GetSalaryRate( anEmployeeProfile( e ) ) );
end WriteEmployeeSalary;

11.4 Objects with Automatic Initialization/Finalizaton

Basic Ada tagged records don't do anything special when they are created or destroyed. If you want special actions to be executed automatically when a tagged record is created or destroyed, you can use the Ada.Finalization package. In this package is defined a special tagged record called Controlled. When you extend this tagged record, you can overload special procedures that Ada will automatically execute when necessary. This saves you from having to explicitly call such procedures yourself.

  type businessDepartment is new Finalization.Controlled with record
    departmentHead : aEmployeeProfilePtr := new
      aSalaryEmployee ( "Bob Smith", age => 45, rate => 42_000.0);
  end record;

In this example, every time you allocate a businessDepartment variable, DepartmentHead is initialized with a dynamic allocation. We could write a procedure to free up this memory, but then we would have to remember to call it every time a variable is about to be discarded. A better way to handle this is to let Ada do the discarding for us. Finalize is the name of the procedure Ada calls when cleaning up a controlled tagged record. We create our own Finalize for our businessDepartment tagged record:

procedure Finalize(bd : in out businessDepartment) is
begin -- Finalize
  Free( bd.departmentHead );
end Finalize;

Now Ada will automatically run this procedure before any businessDepartment variable is destroyed and we never have to worry about forgetting to free up the memory used by departmentHead.

There are two other such automatic procedure we can use with controlled tagged records. Procedure Initialize is used when an object is first created, and procedure Adjust is used after an object is assigned in an assignment statement.

Adjust is very smart. Temporary storage is used for self-assignment. If Adjust fails because of an exception, Finalize is not executed.

with text_io, sample;
use text_io, sample;

procedure controlledtest is
  srp1, srp2 : SampleRecPtr;
  sr3 : SampleRec;
begin
  Put_Line( "(This is the first line of the program)");
  New_Line;
  Put_Line( "This is an example of controlled tagged records:" );
  New_Line;
  Put_Line( "Executing 'srp1 := new SampleRec'");
  srp1 := new SampleRec;
  New_Line;
  Put_Line( "Executing 'srp2 := srp1' (copying a pointer)" );
  srp2 := srp1;
  New_Line;
  Put_Line( "Executing 'sr3 := srp1.all' (copying a record pointed to)" );
  sr3 := srp1.all;
  New_Line;
  Put_Line( "(This is the last line of the program)");
end controlledtest;

with ada.finalization;
use ada.finalization;

package sample is

   type SampleRec is new Controlled with null record;
   type SampleRecPtr is access all SampleRec;
   -- sample controlled tagged record (and a pointer to same)

   procedure Initialize( sr : in out SampleRec );
   procedure Finalize( sr : in out SampleRec );
   procedure Adjust( sr : in out SampleRec );
   -- these are required for controlled tagged records

end sample;

with Ada.text_io;
use Ada.text_io;

package body sample is
  -- just print messages to show that these are working

procedure Initialize( sr : in out SampleRec ) is
  begin
  Put_Line( "Initialize: Initialized tagged record" );
end Initialize;

procedure Finalize( sr : in out SampleRec ) is
begin
  Put_Line( "Finalize: Finalized tagged record " );

end Finalize;

procedure Adjust( sr : in out SampleRec ) is
begin
  Put_Line( "Adjust: Adjusted tagged record " );
end Adjust;

end sample;

Here is the output. The records being affected are noted in bold.

Initialize: Initialized tagged record [sr3]
(This is the first line of the program)

This is an example of controlled tagged records:

Executing 'srp1 := new SampleRec'
Initialize: Initialized tagged record [srp1.all]

Executing 'srp2 := srp1' (copying a pointer)

Executing 'sr3 := srp1.all' (copying a record pointed to)
Finalize: Finalized tagged record [sr3 (before record is copied)]
Adjust: Adjusted tagged record [sr3 (after record is copied)]

(This is the last line of the program)
Finalize: Finalized tagged record [srp1.all]
Finalize: Finalized tagged record [sr3]

Ada also provides a second tagged record, Limited_Controlled, which is a controlled record that can't be assigned. Consequently, it has no adjust procedure.

11.5 Multiple Inheritance

Like a tree, tagged records can only be extended from a single parent. Extending from multiple parents is called multiple inheritance, and Ada doesn't allow multiple inheritance. The Ada designers considered multiple inheritance a feature that adds ambiguity to a language: for example, if an employee tagged record has two different parents, each with a salary field, do you merge the salary fields into one or do you have two copies of the field in your record? Because there is no consistent solution to this kind of problem, the Ada designers decided to not to support multiple inheritance.

However, you can add tagged records as nested fields, just like you would a normal record. This workaround guarantees that each object will only have one parent it can extend from.

type aClass is tagged record
  F1 : integer;
end record;

type anUnrelatedClass is tagged record
  U1 : integer;
  end record;

type anMIExample is new aClass with
  UC : anUnrelatedClass; -- a field, not an extension
end record;

anMIExample is a tagged record belonging to aClass, not to anUnrelatedClass. If you extend anMIExample, it will inhert F1 from its parent class. Since anUnrelatedClass UC is nested, you can still access it as a field using the prefix "UC.".

[ BETTER EXAMPLE -- KB ]

11.6 Private Objects

package customers is

  type AbstractCustomer is abstract tagged private;

  type BasicCustomer is new AbstractCustomer with private;

private

  type AbstractCustomer is new abstract tagged record
    name : string( 1..80 );
  end record;

  type BasicCustomer is new AbstractCustomer with
    SalesCategory : integer;
  end record;

end customers;

By declaring a tagged record as private, we eliminate all access to the fields in the record. Anybody who wants to change the value of the fields must do it through any subprograms we provide. In object oriented programming, it's a good idea to make as many tagged records private as possible, the same as other private types. That way, if you want to change the contents of the tagged record, programs that use your class will not have to be changed.

11.7 Generics

Ada allows you to create source code templates, called generics. With generics, you can specify a routine with only general information about the kinds of types the routine can work on. Later a programmer instantiates the generic by giving a type. Generics are useful for things like sort routines, which work basically the same way on different data types.

Ada contains several standard generic procedures. The most important one is unchecked_deallocation. This long winded procedure deallocates memory allocated with new. In order to free up memory, you must instantiate an unchecked_deallocation for each access type you are going to use new on. You have to specify both the access type and type of data that is being pointed to.

 
with unchecked_deallocation;

type booleanPtr is access all boolean;

procedure Free is new unchecked_deallocation( boolean, booleanPtr );

Free is a new version of unchecked_deallocation compiled for booleanPtr's to a boolean type.

Ada was designed for the possibility automatic storage recovery, that everything that was allocated in a subprogram would be deallocated automatically when the subprogram is left. Unfortunately, gnat was implemented without this feature and all memory has to be explicitly deallocated.

Another standard generic you'll run into is unchecked_conversion. This converts a variable of one type to another by physically copying to data from one to the other, such as an array of 8 bits to a short_short_integer.

Although you can write generic subprograms, most of the time you use generics will be for creating generic packages. Generic packages have a spec and body like normal Ada packages, but they begin with a list of parameters to the package that must be filled in when the generic is instantiated.

generic

  -- these are the parameters for the generic

  type ListElement is <>; -- unspecified list element

  procedure ">="( left, right : ListElement); -- a procedure to sort by

package SimpleList is

  type List is array( 1..100) of ListElement;
  procedure Add( l : list; e : ListElement);
  procedure Sort( l : list );
  procedure Display( l : list );

end SimpleList;

(check--KB)

In this example, SimpleList takes some kind of data type called a ListElement, the items that compose the lists. Besides <>, Ada offers a number of other non-specific type descriptors to give the compiler an idea of what kind of types are acceptable. Since the ListElement could be an aggregate and we can't assume we can do simple comparisons, the programmer must also specify a procedure to sort the elements by.

Once you write the package body (no generic section in the package body, just a regular package body), you can instantiate the generic package in a program. After instantiation, use the package like any other package.

with SimpleList;

procedure ListTest is

package BooleanList is new SimpleList( boolean, ">=" )

  -- in this case, the normal ">=" will sort booleans

begin

  BooleanList.Add( mylist, true );
  BooleanList.Add( mylist. False );

end ListTest;

Now you'll notice that generics and tagged records share a lot of capabilities. You can use both to write subprograms that work on a variety of types. Tagged records are referred to as dynamic polymorphism, because which subprogram to call gets determined while the program is running. Generics are referred to as static polymorphism, because the subprograms are generated when the generic is instantiated by the compiler and which subprogram to call is known when the program is compiled. The better approach depends on what you are doing. In general, generics run faster but take up more space because the compiler generates separate subprograms for each type. Tagged records take up less space but tend to run slower.

Variant records and tagged records, likewise, share much in common. Although variant records can be simulated with tagged records, you'll need to decide which is the best choice depending on what you are trying to accomplish. Variant records tend to be smaller and faster, but are harder to extend than tagged records.

Since tagged records are naturally used to create variables that are similar to one another, you might wonder if you'd ever create a single variable of a tagged record type. These are called singletons, and are used in frequently in languages like C++. They are popular because they have a specific elaboration order and provide access to features only available in objects (such as private members). Programmers doing this have no need to create a class of several objects. However, Ada has an easily controlled elaboration process and features such as privacy are not specific to tagged records. As a result, there is rarely a need for singletons in Ada programs.

11.8 Exceptions

What do you do when something unexpected error occurs? Unexpected errors are called exceptions in Ada. For example, running out of memory is an exception.

Ada has a number of predefined exceptions, and examples of when they occur:

• CONSTRAINT_ERROR - number out of range, like assigning -1 to a positive variable
• NUMERIC_ERROR - dividing by zero
• SELECT_ERROR - caused by task select statement with no else part
• STORAGE_ERROR - running out of memory
• TASKING_ERROR - failure of a task to handle an entry call
• PROGRAM_ERROR - hitting the end of a function without returning anything
• ASSERT_ERROR - a pragma assert failed

You can turn off checking for most of these errors using pragmas, but they are usually a sign that something if fundamentally wrong with your program. Gnat provides a compiler option to turn these checks off for the release version of a program.

The standard libraries have additional exceptions defined.

To handle an exception, you need an exception part at the end of a subprogram. When the exception is raised (occurs), execution immediately jumps down to the exception part. The exception part contains a list of exceptions to check for, plus an others part, similar to a case statement.

procedure exceptional( Total : out integer) is
begin
   -- do some stuff
exception
  when constraint_error => Total := 0;
  when storage_error => Total := -1;
  when others => raise;
end exceptional;

Raise causes the exception to be reraised to the calling subprogram.

If one subprogram doesn't handle the exception, it's raised in the subprogram that called it. This continues until the exception is handled by an exception part, or the main program is it. In the worst case, if the main program has no exception part, the program terminates and the exception name is printed on the screen.

One use for exception parts to deallocate access types so the memory isn't lost when unexpected errors occur.

You can define and raise your own exceptions.

procedure exceptional2 is
  Accounting_Error : exception;

Pragma Assert provides an exception for debugging programs. Assert is described in 8.2.

For more advanced manipulation of exceptions, you'll need to use Ada.Exceptions and its related packages. These are described in 12.15.

11.9 Dynamic Allocation

Dynamic allocation is reserving memory for variables while the program is running.  The memory is allocated from a region called the default storage pool. GNAT sometimes refers to this as the unbounded no reclaim pool because the only limit on the amount of memory you can allocate is the physical limit of the machine, and memory is not reclaimed through garbage collection.

Ada uses access types to create a handle to dynamically declared variables.

type IntegerPtr is access all Integer;
ip : integerPtr := new Integer;

In this example, IP access a dynamically declared integer. IP is only large enough to hold the address of where the integer is located. To access the integer, we have to add the suffix .all to IP. This is called dereferencing.

ip.all := 5;

If you are dereferencing multiple pointers, the all is only required at the end to indicate that the final pointer is to be dereferenced ( for example,. ptr1.ptr2.ptr3.all).

The word all in access all is not strictly required. If all is included, the IntegerPtr type will be compatible on any other integer pointer. Without all, Ada imposes certain restrictions on what the access type can point to, but in general always use access all.

Memory allocated with new is freed with unchecked_allocation (see the section on generics).

You can assign initial values when you create a new dynamic variable. In the following example, we declare, allocate memory and assign an initial value all at once.

ip : integerPtr := new Integer( 5 );

To create a record with a pointer to itself, have an empty type statement with the record first:

  type LinkedListRecord;

  type LinkedListPtr is access LinkedListRecord;
  type LinkedListRecord is record
    info : string(1..80);
    next : LinkedListPtr;
  end record;

To point to variables you've declared, you must declare those variables as aliased to indicate they can be pointed to. To get the address of something, use the 'access attribute.

  type CustomerArray is array(1..100) of CustomerRecord;
  type CustomerArrayPtr is access all CustomerArray;

  ca : aliased CustomerArray;
  cp : CustomerArrayPtr := ca'access;

cp now points to ca. Individual array elements can also be aliased.

  type CustomerArray is array(1..100) of aliased CustomerRecord;

  type CustomerArrayPtr is access all CustomerArray;

   ca : CustomerArray;
   c15p : CustomerArrayPtr := ca(15)'access;

Ada will give you an error when you try to use 'access when the object pointing to may disappear after the pointer does. If you're absolutely certain that this won't happen, you can circumvent the error by using 'unchecked_access.

An access type is necessarily just the address of a dynamic object. To get the address of an access type, it's best to use gnat's generic package System.Address_To_Access_Conversions.

  type intacc is access all integer;
  package strConvert is new System.Address_To_Access_Conversions(intacc);
...
  string_address := strConvert.To_Address( SomeIntAccVar );

11.10 Callbacks

A callback is a pointer to a subprogram. They are called callbacks because you usually give the pointer to another subprogram that calls the procedure pointed to whenever it needs to. You can declare callbacks using type.

  type UpdateWindow is access procedure;
  type DisplayNewValue is access procedure( newval : integer );

One important restriction is that Ada requires that callbacks to refer to global subprograms. This is done to ensure that the access variable always points to an existing subprogram. You cannot create a callback to a local procedure or function, even if it's perfectly safe to do so. If you try, you'll get an obscure error message about one level being deeper than another.

The gnat equivalent for 'unchecked_access for callbacks is 'unrestricted_access, which you can use if you're absolutely sure the subprogram you're using will not save the access when it's finished running.

You can get the address of a procedure using 'access. Suppose MyUpdateProcedure is a procedure fitting the description of UpdateWindow, a procedure with no parameters.

  updatePtr : UpdateWindow := MyUpdateProcedure'access;
  procedure DoComplexSlowComputation( updatePtr);

To call a callback, use the dereference operator .all.

  UpdatePtr.all;

11.10.1 Storage Pools

Unlike languages like C that have only one storage pool, Ada allows you to define your own storage pools. Authors of real-time applications, for example, can create a pool with a maximum size limit or a fixed access time.

Use a  for clause to make an access type use a pool other than the default storage pool.

  type AccountingRecPtr is access all AccountingRec;
  for AccountingRecPtr'storage_pool use my_pool;

Gnat defines several storage pools besides the default storage pool. Perhaps the most useful is the debug pool. This storage pool, available in version of Gnat before 3.12, works the same as the default storage pool except that it performs run-time checks for several different pointer related problems. If a check fails, an exception is raised.

The following program illustrates the errors caught by debug pool access types.

  with Ada.Text_IO, System.Pool_Local, System.Debug_Pools;
  use Ada.Text_IO;

  with unchecked_deallocation;

  -- This is an example of using the GNAT-specific debug_pool
  -- storage pool.

  procedure debpools is

    type sales_record is record

      salesman_code : integer;
      sales_amount : float;

    end record;

     -- just a typical record

    type salesptr_normal is access all sales_record;

    --
    -- This is a normal access type. It is allocated
    -- in the default storage pool (aka "the heap").
    -- The default storage pool is called
    -- Unbounded_No_Reclaimed_Pool. That is, there's
    -- no size limit, and memory is not reclaimed by
    -- garbage collection.
    -- A debug pool
    -----------------------------------------

  sales_debug_pool : System.Debug_Pools.Debug_Pool;

  -- declare a new debug pool
  --
  -- Debug_Pool is a GNAT-specific pool.

  type salesptr_debug is access all Sales_Record;

  for salesptr_debug'storage_pool

    use Sales_Debug_Pool;

  -- This access type has no garbage collection
  -- but raises exceptions on allocation or
  -- deallocation errors, useful for tracking down
  -- storage leaks. All 4 possible exceptions are
  -- shown in this program.

  procedure Free is new Unchecked_Deallocation( sales_record,
    salesptr_debug );
  -- procedure to deallocate salesptr_debug access types

    sr : aliased Sales_Record;
    spd, spd2, spd3 : salesptr_debug;

  begin

    Put_Line( "Fun with debug storage pools!");
    New_Line;

    -- Debug Pool Exception #1

    begin

       Put_Line( "Accessing a non-allocated access type is an exception:" );
       Put_Line( "spd.salesman_code := 1");

       spd.salesman_code := 1; -- error: not allocated
    exception when System.Debug_Pools.Accessing_Not_Allocated_Storage =>
       Put_Line( "***Accessing_Not_Allocated_Storage raised" );
    when others =>
       Put_Line( "***Unexpected exception" ); raise;
    end;

    New_Line;
    -- Debug Pool Exception #2

    begin
      Put_Line( "Freeing a non-allocated access type is an exception:" );
      Put_Line( "spd2 := sr'access --not allocated in pool" );
      Put_Line( "Free( spd2 )" );
      spd2 := sr'access;
      Free( spd2 );
    exception when
      System.Debug_Pools.Freeing_Not_Allocated_Storage =>
      Put_Line( "***Freeing_Not_Allocated_Storage raised" );
    when others =>
      Put_Line( "***Unexpected exception" ); raise;
    end;
    New_Line;

    spd := new Sales_Record'( salesman_code => 1, sales_amount => 55.50 );
    -- Debug Pool Exception #3

    begin
      Put_Line( "Accessing deallocated access type is an exception:" );
      Put_Line( "spd := new Sales_Record...");
      Put_Line( "Free( spd )" );
      Put_Line( "spd.salesman_code := 1");
      Free( spd );
      spd.salesman_code := 1; -- error: not allocated
    exception when System.Debug_Pools.Accessing_Not_Allocated_Storage =>
      Put_Line( "***Accessing_Deallocated_Storage raised" );
    when others =>
      Put_Line( "***Unexpected exception" ); raise;
    end;
    New_Line;

    spd := new Sales_Record'( salesman_code => 1, sales_amount => 55.50 );
    -- Debug Pool Exception #4

  begin
     Put_Line( "Freeing deallocated access type is an exception:" );
     Put_Line( "spd := new Sales_Record...");
     Put_Line( "spd2 := spd" );
     Put_Line( "Free( spd )" );
     Put_Line( "Free( spd2 )" );
     spd2 := spd;
     Free( spd );
     Free( spd2 );
  exception when System.Debug_Pools.Freeing_Deallocated_Storage =>

    Put_Line( "***Freeing_Deallocated_Storage raised" );
  when others =>
    Put_Line( "***Unexpected exception" ); raise;
  end;
  New_Line;

end debpools;

Fun with debug storage pools!

Accessing a non-allocated access type is an exception:
spd.salesman_code := 1
***Accessing_Not_Allocated_Storage raised

Freeing a non-allocated access type is an exception:
spd2 := sr'access --not allocated in pool
Free( spd2 )
***Freeing_Not_Allocated_Storage raised

Accessing deallocated access type is an exception:
spd := new Sales_Record...
Free( spd )
spd.salesman_code := 1
***Accessing_Deallocated_Storage raised

Freeing deallocated access type is an exception:
spd := new Sales_Record...
spd2 := spd
Free( spd )
Free( spd2 )
***Freeing_Deallocated_Storage raised

To create your own storage pools, you need to extend the Root_Storage_Pool tagged record found in the System.Storage_Pools package.

[give example--KB]
 

11.10.2 Access Parameters

Because pointers are offen passed as parameters, Ada provides a special parameter type just for access types. access parameters are access types behave the same as an in parameter: you cannot assign a new value to the parameter. However, because it is an access type, you can change what the access parameter points to.

Access parameters offer some advantages over in parameters with an access type:

• Ada will verify that the parameter isn't null
• Access parameters can be used in functions where in out parameters are not allowed
• They avoid access type accessibility errors (without resorting to 'unchecked_access)

Access parameters can't be compared or assigned, but you can typecast an access parameter into a normal access type and then compare values or assign it.

with Ada.Text_IO;
use Ada.Text_IO;

procedure accparm is
  -- An example of access parameters

  -- Create a customer account record

  type money is new float;
  type aPercent is new float;

  type aCustomerAccount is record
       moneyOwing : money := 0.0;      -- money on the account
       interest   : aPercent := 0.15;  -- 15% interest
  end record;
  type aCustomerPtr is access all aCustomerAccount;


  procedure chargeInterest( cp : access aCustomerAccount ) is
    -- update the customer record by charging the interest
  begin
    cp.moneyOwing := cp.moneyOwing * money(1.0 + cp.interest );
  end chargeInterest;

  procedure chargeInterest2( c : in out aCustomerAccount ) is
    -- update the customer record by charging the interest
  begin
    c.moneyOwing := c.moneyOwing * money(1.0 + c.interest );
  end chargeInterest2;

  function chargeInterest3( cp : access aCustomerAccount ) return boolean is
    -- update the customer record by charging the interest
    -- if under 1000, don't charge interest and return false
  begin
    if cp.moneyOwing < 1000.0 then
       return false;
    end if;
    cp.moneyOwing := cp.moneyOwing * money(1.0 + cp.interest );
    return true;
  end chargeInterest3;

   cp : aCustomerPtr;

begin

   Put_Line( "An Example of Access Parameters" );
   New_Line;

   cp := new aCustomerAccount;

   Put_Line( "chargeInterest uses an access parameter" );
   cp.moneyOwing := 1500.0;
   Put_Line( "Charging interest on" & cp.moneyOwing'img );
   chargeInterest( cp ); 
   Put_Line( "After interest, money owing is" & cp.moneyOwing'img );
   New_Line;

   Put_Line( "chargeInterest2 uses an in out parameter" );
   cp.moneyOwing := 1700.0;
   Put_Line( "Charging interest on" & cp.moneyOwing'img );
   chargeInterest2( cp.all ); 
   Put_Line( "After interest, money owing is" & cp.moneyOwing'img );
   New_Line;

   Put_Line( "chargeInterest3 is a function with an access parameter" );
   cp.moneyOwing := 1900.0;
   Put_Line( "Charging interest on" & cp.moneyOwing'img );
   if chargeInterest3( cp ) then
      Put_Line( "After interest, money owing is" & cp.moneyOwing'img );
   else
      Put_Line( "No interest was charged" );
   end if;
   New_Line;

   Put_Line( "A null pointer for an access parameter causes an exception" );
   cp := null;
   Put_Line( "Charging interest on a null pointer" );
   if chargeInterest3( cp ) then
      Put_Line( "After interest, money owing is" & cp.moneyOwing'img );
   else
      Put_Line( "No interest was charged" );
   end if;
   New_Line;

exception
   when constraint_error =>
        Put_Line( Standard_Error, "Constraint error exception raised" );
   when others =>
        Put_Line( Standard_Error, "Unexpected exception raised" );

end accparm;

An Example of Access Parameters

chargeInterest uses an access parameter
Charging interest on 1.50000E+03
After interest, money owing is 1.72500E+03

chargeInterest2 uses an in out parameter
Charging interest on 1.70000E+03
After interest, money owing is 1.95500E+03

chargeInterest3 is a function with an access parameter
Charging interest on 1.90000E+03
After interest, money owing is 2.18500E+03

A null pointer for an access parameter causes an exception
Charging interest on a null pointer
Constraint error exception raised

11.11 Multithreading

Gnat comes with two alternative libraries for multithreading support. It can either use the native Linux pthreads (built into libc6), or it can use FSU (Florida State University) threads that are included with gnat. By default, the Linux version of gnat is compiled for Linux native threads.

11.11.1 FSU verses Native Threads

The FSU threads provide better concurrency at very small time slices, but are incompatible with Linux's pthreads library. This means you can't use the FSU version of gnat with the standard Linux libraries unless you recompile the libraries for FSU threads as well. FSU threads also force blocking on system calls and can cause blocking problems multiprocessors, and as a result most people don't use them. One exception is Florist, a POSIX (that is, Linux O/S calls) binding using FSU threads. The main benefit of FSU threads is that they are Ada Annex C & D compliant.

To use FSU threads, you need to compile gnat from its sources.

11.11.2 Tasks

In Ada, a thread is referred to ask a task. It has nothing to do with multitasking, as its name might imply. A task runs independently of the main program, either by true parallelism on a multiprocessor computer, or as a separate job on a single processor computer. There is no way to specify which processor will receive a task: Linux takes care of this automatically.

Multithreaded programs have limits on the stack size for each thread--this is true for all Linux computer languages. Gnat 3.13 has an 8 Meg stack size limit per thread. Older versions had limits as low as 1 Meg per thread because of limits imposed by the Linuxthreads library.

A task can take on several forms. In its simplest form, a task is structured like a package, with a specification and a body. The following is an example of a simple thread that waits 5 seconds after a program is started and displays a message.

  task SimpleTask;
  task body SimpleTask is
  begin
    delay 5.0;
    Put_Line( "The simple task is finished");
  end SimpleTask;

The specification, like a package, indicates what identifiers are available to the outside world. The SimpleTask thread doesn't communicate with the main program: it's specification is only one line long.

Communicating with the rest of the program can be difficult. For example, with the tasks and main program running in parallel, sharing variables can be difficult. How does one task know when another task or the main program is finished changing the value of a variable? If a task works with a variable that's only partially been udpated, the data will be corrupt.

Ada provides two ways for a thread to communicate with the rest of the program.

The first communication method is called a rendezvous. One task communicates with another by sending a request. A task may send a request to another task to update a certain variable, or to perform a certain action, that would otherwise risk data corruption.

Because this communication happens "on the fly", it's declared in two parts. First, in the task specification, a list of all requests the task is prepared to accept. These are called entry statements and look much like procedure declarations.

Suppose we write a task to keep a running total, to be shared between several other tasks. We use a separate task to keep the total from being corrupted.

  task CountingTask is
    entry add( amount : integer );
  end CountingTask;

In the task body, a task indicates when it's ready to accept messages using the accept statement. This statement checks for outstanding requests from the rest of the program.

  task body CountingTask is
    runningTotal : integer := 0;
  begin
    loop
      accept add( amount : integer ) do
      runningTotal := runningTotal + amount;
      end add;
    end loop;
  end CountingTask;

When this thread runs, accept statement will check for an add request. If there are no outstanding add requests, the thread suspends itself until a request is sent, waiting indefinitely for a new request. Suspending for a request is known as blocking.

An accept statement with do part will cause your task to wait for that request and then do nothing. You can do this to synchronize two tasks.

  accept WaitUntilITellYouToGo;

Suppose we add another entry statement to read the current value of the running total.

  task CountingTask is
    entry add( amount : integer );
    entry currentTotal( total : out integer);
  end CountingTask;

In this case, we want the task to check for two different requests. The Ada select statement keeps a task from blocking and instead checks for multiple messages.

  task body CountingTask is
    runningTotal : integer := 0;
  begin
    loop
      select
        accept add( amount : integer ) do
          runningTotal := runningTotal + amount;
        end add;
      or
        accept currentTotal( total : out integer ) do
          total := runningTotal;
        end currentTotal;
      end select;
    end loop;
  end CountingTask;

In this example, the task will repeatedly check for an add request or a currentTotal request.

To communicate with the task, we make calls to the task as if it were a package. For example, to send a message to add 5 to the running total, we'd use

  CountingTask.Add( 5);

Because accept is a statement that executes at run-time, you can create any kind of message policy you want. Some messages can block. Some messages can be checked. You can force certain message to be handled before others.

The final "or" part of a select can contain instructions to execute when none of the accepts statements are executed. For example, a task can end itself with the terminate command. If you want a task to terminate when there are no more requests, add a

  or
    terminate

at the end of your select statement.

If select statement doesn't give you enough control over blocking, select can include when clauses. The clauses work like an if statement, executing the accept statement only if a condition is true. If time2accept is a boolean variable, you could write

  select
    when time2accept =>
      accept add( amount : integer ) do

A when clause is referred to as a "guard" because, like a crossing guard, the accept will not execute unless the guard gives permission.

Ada also has a delay statement. Delay forces a task (or a program) to suspend itself for a number of seconds. To wait for three-and-a-half seconds, use

  delay 3.5;

You can place a delay statement in the last "or" part of a select statement to force the task to suspend itself for a few seconds if no requests were found.

Delay can also wait for a particular time. The time is expressed using the Ada.Calendar time format. If Tomorrow is a variable with the time of midnight tomorrow in the Ada.Calendar time format, you can delay the start of a task with

  delay until Tomorrow;

In an emergency, one task can terminate another with the abort statement.

  abort CounterTask;

Ada provides a variation of the select statement for tasks that timeout when they cannot complete their work in time. This version has two parts: the first part consists of what to do if the task isn't completed in time, and the second consists of the task to complete. For example, if BigCalculation is a slow process that we wish to timeout after 30 seconds,

  select delay 30.0;
    Put_Line( "Timeout!" );
  then abort
    BigCalculation;
  end select;

In this example, BigCalculation will continue for up to 30 seconds. If it doesn't finish, "Timeout!" is displayed and BigCalculation is aborted.

11.11.3 Task Types

Often multithreaded programs will need a set of identical tasks. For example, you many want to sort a customer's records for several different customers using different threads. You can't do this with the simple tasking examples shown so far.

To create a set of identical tasks, you must create a template of the tasks to run. Ada calls these templates a task type: they look just like a regular task except the specification begins with "task type" instead of "task" by itself. The following is a task template using the CountingTask example.

  task type CountingTask is
    entry add( amount : integer );
    entry currentTotal( total : out integer );
  end CountingTask;

This template will not run by itself. If we want to create a CountingTask task, we create one by declaring it.

  Task1, Task2 : CountingTask;

Task1 and Task2 are two copies of CountingTask. This is equivalent to creating two separate tasks:

  task Task1 is
    entry add( amount : integer );
    entry currentTotal( total : out integer);
  end Task2;

  task Task2 is
    entry add( amount : integer );
    entry currentTotal( total : out integer);
  end Task2;

Because task types can be declared, we can create 20 tasks at once by declaring an array of 20 CountingTask's.

  CountingTasks : array(1..20) of CountingTask;

Tasks can also be declared in records as well, or allocated dynamically using the new operator.

  type aTaskPtr is access CountingTask;
  tp : aTaskPtr;
  ...
  tp := new CountingTask;

Using new, you can create as many copies of a particular task as you need.

11.11.4 Protected Items/Types

Ada tasks are useful for many kinds of multithreading. However, Ada provides a second method of multithreading called protected objects. These are similar to the "monitors" used by Java.

In an Ada task, you specify when and how different tasks communicate. When items are declared protected, Ada controls the interaction for you.

Protected objects are declared the same was as a package, using a specification and a body. They act like a package that allows only one task access to its contents at a time. While one task is using the contents, any other task wanting access is blocked until the first task is finished.

Here is our CountingTask rewritten as a protected item.

  protected CountingType is
    procedure add( amount : integer);
    procedure currentTotal( total : out integer );
  private
    runningTotal : integer := 0;
  end CountingType;

  protected body CountingType is
    procedure add( amount : integer ) is
    begin
      runningTotal := runningTotal + amount;
    end add;

    procedure currentTotal( total : out integer ) is
    begin
       total := runningTotal;
    end currentTotal;

  end CountingType;

In this case, any task may execute the add or currentTotal procedures, but only one task may execute them at a time. This ensures that runningTotal will not be corrupted.

Unlike a package, you can't declare variables in the spec or body unless you put them in a "private" part in the spec.

Protected items can include entry declarations. Since there is no "main program" to the protected body, the protected body contains no accept statements. Instead, the entry declarations are filled in as if they were a subprogram. Any guarding conditions are attached to the end of the entry header.

For example, to create an a version of our add procedure that blocks if the total is higher than 100, we could write

  protected CountingType is
    entry add( amount : integer );
...
  protected body CountingType is
    entry add( amount : integer ) when runningTotal<100 is
  begin
    runningTotal := runningTotal + amount;
  end add;
...

Like tasks, you can create protected types by declaring the specification with "protected type" instead of "protected". You can then create arrays of protected items, or declare protected items dynamically.

This covers the basics of Ada's multithreading capabilities. There's much more that Ada can do. If you are writing complicated multithreading programs, you're encouraged to investigate the Ada Reference Manual for more information.
 

11.12 Ada Text Streams

A stream is a sequential transmission of different types of data. When data is written to a stream, the stream converts the data to a form suitable for transmission. When the data is read, it's converted from the stream's format back to its original form.

A practical example is saving tagged records belonging to the same class to a file.

Ada's syntax for using streams is a bit cumbersome. Like tagged records, some of the features are implemented using attributes, and others are found in standard packages.

The Ada.Streams.Stream_IO can write heterogeneous data to a text file, and then read it back again. This package contains a number of subprograms similar to Ada.Text_IO, including, Open, Close, Reset, Delete, Is_Open and End_Of_File.

However, there are no Get or Put procedures. Instead, there are stream subprograms for working with the data in the file.

• Stream - returns a stream to the file
• Read - read data from the stream
• Write - write data to the stream

Read and Write are not used directly. Instead, the attributes 'read and 'write will read and write an item to the stream. That is, Gnat does the necessary conversion to stream data for you.

For classes of tagged records, 'input and 'output read and write any child of the class. These attributes are implicitly defined for all class-wide types (that are not also limited). As a result, you usually combine 'class with the stream attributes for 'class'input and 'class'output. If you don't supply 'class, nothing will be written and no exception will be raised.

with ada.text_io, ada.streams.stream_io;
use  ada.text_io, ada.streams.stream_io;
with ada.unchecked_deallocation;

procedure class_stream is

  -- Contact_Info: A simple class
  -- the base class must not be abstract when using 'input and 'output

  type contact_info is tagged null record;
  type contact_ptr is access all contact_info'class;

  type phone_number is new contact_info with record
       phone : string(1..14);
  end record;

  type office_number is new contact_info with record
       office : integer;
  end record;

  procedure free is new ada.unchecked_deallocation(
     contact_info'class, contact_ptr);

  -- A Stream File and Its Stream

  stream_file : Ada.Streams.Stream_IO.File_Type;
  the_stream  : Ada.Streams.Stream_IO.Stream_Access;

  contact : contact_ptr;

begin

  Put_Line( "An example of Ada.Streams.Stream_IO and a Class" );
  Put_Line( "-----------------------------------------------" );
  New_Line;

  Create( stream_file, out_file, "contact_list.stream" );
  Put_Line( "Created a stream file" );
  -- open the stream file

  the_stream := stream( stream_file );
  -- get a stream representing the file's contents

  contact := new phone_number'( phone => "1-905-555-1023" );
  contact_info'class'output( the_stream, contact.all );
  free( contact );
  Put_Line( "Wrote a phone number" );
  -- write a record

  contact := new office_number'( office => 8023 );
  contact_info'class'output( the_stream, contact.all );
  free( contact );
  Put_Line( "Wrote an office number" );
  -- write a record

  Close( stream_file );
  New_Line;
  -- close the stream file

  -- Read Them

  Open( stream_file, in_file, "contact_list.stream" );
  Put_Line( "Opened a stream file" );
  -- open the stream file

  the_stream := stream( stream_file );
  -- get a stream representing the file's contents

  while not End_of_File( stream_file ) loop
    declare
       contact : contact_info'class := contact_info'class'input( the_stream );
    begin
       -- if this were more sophisticated, we could write a Put procedure
       -- for each tagged record and use dynamic dispatching
       if contact in phone_number then
          Put_Line( "read a phone number" );
       elsif contact in office_number then
          Put_Line( "read an office number" );
       else
          Put_Line( "read something else" );
       end if;
    end;
  end loop;

  Close( stream_file );
  -- close the stream file

end class_stream;

An example of Ada.Streams.Stream_IO and a Class
-----------------------------------------------

Created a stream file
Wrote a phone number
Wrote an office number

Opened a stream file
read a phone number
read an office number

Files of items of the same time are more easily created with Ada.Sequential_IO or Ada.Direct_IO.

Custom streams can be created to save or trasmit data in other ways such as in memory or through a network connection. Custom streams are created as tagged records extended from a root class, Ada.Streams.Root_Stream_Type'class.

    type My_Stream is new Root_Stream_Type with record
    ...

Your stream type must override the abstract Red and Write subprograms to add and remove data from the stream.

The following is an in-memory stream creating by Warren Gay. This stream can share data between programs, buffering the data as text in memory. If a buffer overflow occurs, an END_ERROR is raised.

-- $Id: memory_stream.ads,v 1.1 2000/11/26 05:00:18 wwg Exp $
-- (c) Warren W. Gay VE3WWG ve3wwg@home.com, ve3wwg@yahoo.com
--
-- Protected under the GNU GPL License

with Ada.Finalization, Ada.Streams;
use  Ada.Finalization, Ada.Streams;

package Memory_Stream is

    type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;
    type Memory_Buffer(Max_Elem: Stream_Element_Offset) is new Controlled with private;

    --------------------------------------------------
    -- The new Stream Type, which must be derived from
    -- Root_Stream_Type. Note that Root_Stream_Type is
    -- NOT derived from Controlled, so if
    -- controlled attributes are necessary, they must
    -- be defined separately, and embedded into this
    -- object, as is done with Memory_Buffer here.
    --------------------------------------------------
    type Memory_Buffer_Stream(Max_Elem: Stream_Element_Offset) is new Root_Stream_Type with record
            Mem_Buf:        Memory_Buffer(Max_Elem);   -- Object with Finalization
    end record;
 
    type Memory_Buffer_Stream_Ptr is access all Memory_Buffer_Stream;

    -- The overloaded abstract for Read
    procedure Read(Stream: in out Memory_Buffer_Stream;
        Item: out Stream_Element_Array; Last: out Stream_Element_Offset);

    -- The overloaded abstract for Write
    procedure Write(Stream: in out Memory_Buffer_Stream;
        Item: in Stream_Element_Array);

    -- Rewind the Read Memory Buffer Index
    procedure Rewind_Read(Stream: Stream_Access);

    -- Rewind the Write Memory Buffer Index
    procedure Rewind_Write(Stream: Stream_Access);

    -- To permit easy destruction of this stream
    procedure Free(Stream: Stream_Access);

private

    --------------------------------------------------
    -- To create a Memory_Buffer stream with an
    -- Initialize procedure, it must be derived from
    -- a Controlled type. Unfortunately, the type
    -- Root_Stream_Type is not derived from the
    -- Controlled type, so it is done privately here.
    --------------------------------------------------
    type Memory_Buffer(Max_Elem: Stream_Element_Offset) is new Controlled with record
            Read_Offset:    Stream_Element_Offset;
            Write_Offset:   Stream_Element_Offset;
            Buffer:         Stream_Element_Array(1..Max_Elem);
    end record;

    procedure Initialize(Buf: in out Memory_Buffer);
    procedure Write(Buf: in out Memory_Buffer; Item: in Stream_Element_Array);
    procedure Read(Buf: in out Memory_Buffer;
        Item: out Stream_Element_Array;
        Last: out Stream_Element_Offset);
    procedure Rewind_Read(Buf: in out Memory_Buffer);
    procedure Rewind_Write(Buf: in out Memory_Buffer);

end Memory_Stream;

-- $Id: memory_stream.adb,v 1.1 2000/11/26 05:00:18 wwg Exp $
-- (c) Warren W. Gay VE3WWG ve3wwg@home.com, ve3wwg@yahoo.com
--
-- Protected under the GNU GPL License

with Ada.Text_IO; use Ada.Text_IO;

with Ada.Finalization; use Ada.Finalization;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;

package body Memory_Stream is

    --------------------------------------------------
    -- Read from a Memory Buffer Stream :
    --------------------------------------------------
    procedure Read(Stream: in out Memory_Buffer_Stream; Item: out Stream_Element_Array; Last: out Stream_Element_Offset) is
    begin
        Read(Stream.Mem_Buf,Item,Last);
    end Read;

    --------------------------------------------------
    -- Write to a Memory Buffer Stream :
    --------------------------------------------------
    procedure Write(Stream: in out Memory_Buffer_Stream; Item: in Stream_Element_Array) is
    begin
        Write(Stream.Mem_Buf,Item);
    end Write;

    --------------------------------------------------
    -- Rewind the Read Memory Buffer Index
    --------------------------------------------------
    procedure Rewind_Read(Stream: Stream_Access) is
        Mem_Str:    Memory_Buffer_Stream_Ptr := Memory_Buffer_Stream_Ptr(Stream);
    begin
        Rewind_Read(Mem_Str.Mem_Buf);
    end Rewind_Read;

    --------------------------------------------------
    -- Rewind the Write Memory Buffer Index
    --------------------------------------------------
    procedure Rewind_Write(Stream: Stream_Access) is
        Mem_Str:    Memory_Buffer_Stream_Ptr := Memory_Buffer_Stream_Ptr(Stream);
    begin
        Rewind_Write(Mem_Str.Mem_Buf);
    end Rewind_Write;

    --------------------------------------------------
    -- Free a Memory Buffer Stream :
    --------------------------------------------------
    procedure Free(Stream: Stream_Access) is
        type Memory_Buffer_Stream_Ptr is access all Memory_Buffer_Stream;
        procedure Free_Stream is new Ada.Unchecked_Deallocation(Memory_Buffer_Stream,Memory_Buffer_Stream_Ptr);
        Str_Ptr:    Memory_Buffer_Stream_Ptr := Memory_Buffer_Stream_Ptr(Stream);
    begin
        Free_Stream(Str_Ptr);
    end Free;

    --------------------------------------------------
    -- Private Implementation :
    --------------------------------------------------

    --------------------------------------------------
    -- Initialize a Memory_Buffer Object :
    --------------------------------------------------
    procedure Initialize(Buf: in out Memory_Buffer) is
    begin
        Buf.Read_Offset := Buf.Buffer'First;
        Buf.Write_Offset := Buf.Buffer'First;
    end Initialize;

    --------------------------------------------------
    -- Write to a Memory Buffer Object :
    --------------------------------------------------
    procedure Write(Buf: in out Memory_Buffer; Item: Stream_Element_Array) is
        Count:      Stream_Element_Offset := Item'Last + 1 - Item'First;
        Last:       Stream_Element_Offset := Buf.Write_Offset + Count - 1;
    begin

        if Last > Buf.Buffer'Last then
            raise Ada.IO_Exceptions.End_Error;
        end if;

        Buf.Buffer(Buf.Write_Offset..Last) := Item;
        Buf.Write_Offset := Buf.Write_Offset + Count;
    end Write;

    --------------------------------------------------
    -- Read from a Memory Buffer Object :
    --------------------------------------------------
    procedure Read(Buf: in out Memory_Buffer; Item: out Stream_Element_Array; Last: out Stream_Element_Offset) is
        Xfer_Count: Stream_Element_Offset := Item'Last + 1 - Item'First;
        Data_Count: Stream_Element_Offset := Buf.Write_Offset - Buf.Read_Offset;
    begin

        if Xfer_Count > Data_Count then
            Xfer_Count := Data_Count;
        end if;

        Item(1..Xfer_Count) := Buf.Buffer(Buf.Read_Offset..Buf.Read_Offset+Xfer_Count-1);
        Buf.Read_Offset := Buf.Read_Offset + Xfer_Count;
        Last := Item'First + Xfer_Count - 1;
    end Read;

    --------------------------------------------------
    -- Rewind the Read offset in the Memory Buffer
    --------------------------------------------------
    procedure Rewind_Read(Buf: in out Memory_Buffer) is
    begin
        Buf.Read_Offset := Buf.Buffer'First;
    end Rewind_Read;

    --------------------------------------------------
    -- Rewind the Write offset in the Memory Buffer
    --------------------------------------------------
    procedure Rewind_Write(Buf: in out Memory_Buffer) is
    begin
        Buf.Read_Offset := Buf.Buffer'First;    -- Implies a Read offset rewind
        Buf.Write_Offset := Buf.Buffer'First;   -- Rewind the write offset
    end Rewind_Write;
end Memory_Stream;

-- $Id: main.adb,v 1.1 2000/11/26 05:00:18 wwg Exp $
-- (c) Warren W. Gay VE3WWG ve3wwg@home.com, ve3wwg@yahoo.com
--
-- Protected under the GNU GPL License

with Ada.Text_IO;
use Ada.Text_IO;

with Memory_Stream;
use Memory_Stream;

--------------------------------------------------
-- This is a demo main program, that makes use of
-- our home-brewed Memory_Buffer_Stream.
-- 
-- To demonstrate, a record of type my_rec is
-- written to the stream with known values, and
-- then is read back twice, into records T and U.
-- 
-- Then the write offset is rewound, and a new
-- float variable F is written, and then read
-- back into float variable G.
--------------------------------------------------
procedure Main is
    type my_rec is record          -- A demonstration record
            A:      natural;
            B:      integer;
            S:      string(1..8);
            Z:      float;
    end record;

    Str:    Stream_Access := null;               -- A Stream
    R:      my_rec := ( 23, -95, "oink    ", 1.414 );   -- An initialized record

    T:      my_rec := ( 0, 0, "        ", 0.0 );        -- For 1st read
    U:      my_rec := T;                                -- For 2nd read

    F:      float := 29.99;                             -- An initialized float
    G:      float := 0.0;                               -- For 3rd read

begin

    put_line("Demonstration has begun:");

    Str := new Memory_Buffer_Stream(4096); -- Create in-memory buffer stream (4096 bytes)

    my_rec'write(Str,R);                        -- Write record R to stream

    my_rec'read(Str,T);                         -- Read stream back to record T

    put_line("T.A :=" & natural'image(T.A));    -- Dump out T
    put_line("T.B :=" & integer'image(T.B));
    put_line("T.S := '" & T.S & "'");
    put_line("T.Z := " & float'image(T.Z));

    Rewind_Read(Str);                           -- Rewind the read pointer

    my_rec'read(Str,U);                         -- Now read into record U

    put_line("U.A :=" & natural'image(U.A));    -- Dump out U
    put_line("U.B :=" & integer'image(U.B));
    put_line("U.S := '" & U.S & "'");
    put_line("U.Z := " & float'image(U.Z));

    Rewind_Write(Str);                          -- Implies a read rewind also

    float'write(Str,F);                         -- Write F to stream

    float'read(Str,G);                          -- Read stream into G

    put_line("G :=" & float'image(G));          -- Report G for verification

    Free(Str);                                  -- Delete stream

    put_line("Demonstration complete.");
end Main;

Demonstration has begun:
T.A := 23
T.B :=-95
T.S := 'oink    '
T.Z :=  1.41400E+00
U.A := 23
U.B :=-95
U.S := 'oink    '
U.Z :=  1.41400E+00
G := 2.99900E+01
Demonstration complete.

11.13 Pragmas

Pragmas, sometimes called compiler directives, are statements that provide additional information to the compiler build a better executable. Pragmas never change the meaning of a program.

The following are the predefined Ada 95 pragmas:

* - GNAT specific

The use of these pragmas are covered in detail in the GNAT and Ada 95 reference manuals.

11.14 Low-Level Ada

Ada contains a number of low-level features and libraries, such as the ability to add machine code to a program or to access a hardware register in memory. I'll mention a few of these features here.

If you need to specify a specific number of bits, say to access a hardware register, use the for statement.

  type Reg is new integer; 
  for Reg'size use 4; -- register is 4 bits
  type RegPtr is access all Reg;

You can refer an access type to a particular address using  for var'address clause. Together with  'size , you can theoretically refer to an bit in the computer's memory. However, on Linux the address refers to a location in your address space and doesn't refer to a real physical location.

var'alignment will align storage to a particular byte boundary. var'bit_order can specify a different bit order for a record than the default for your machine. The bit orders are defined in the System package. (Gnat 3.12 doesn't fully support bit orders.)

  for Reg'address use 16#2EF#; -- hex address 2EF in your memory space
  for Reg'alignment use 2; -- align to 16-bit boundaries
  for myRecord'bit_order use system.low_order_first; -- low bits to high machine

If the register value can change independently of the Ada program (usually true), we need to mark the pointer with pragma volatile to make sure the compiler will make no assumptions while optimizing.

  pragma volatile( RegPtr);

Ada will do bit-wise logic operations, but it will only do them on packed arrays of booleans or modular types. You can't do bit-wise operations on integers, for example. The bit-wise operators are and, or, xor and not.

  type byte is array(1..8) of boolean;
  pragma pack( byte );

   b1, b2, b3 : byte;
   ...
   b3 := b1 and b2;

If you need octal or hexadecimal numbers, Ada denotes these by using a leading base designation between 2 and 16, with the value delimited by number signs.

  Hex := 16#0FE9#;
  Bin := 2#01101010#;

The System.Machine_Code package can embed assembly language instructions in an Ada program. Since Gnat is based on Gcc, it uses Gcc's inlining features. If you've inlined assembly code in a C program, you'll find Gnat's capabilities virtually identical.

Assembly code is embedded using the Asm.

  Asm( "nop" ); -- do nothing

A tutorial by Jerry van Dijk is available from AdaPower.com.

Large sections of assembly code should be linked in separately.