Изучая Аду

Курсы

- Введение в язык Ада

- Безопасное и надежное программное обеспечение

Footnotes

Введение в язык программирования Ada

Release 2022-08

Aug 22, 2022

Copyright © 2018 – 2022, AdaCore

Эта книга опубликована под лицензией CC BY-SA, что означает, что вы можете копировать, распространять, переделывать, преобразовывать и использовать контент для любых целей, даже коммерческих, при условии, что вы предоставляете соответствующую информацию, предоставляете ссылку на лицензию и указываете, были ли внесены изменения. Если вы делаете ремикс, трансформируете или основываетесь на материале, вы должны распространять свои материалы под той же лицензией, что и оригинал. Вы можете найти подробную информацию о лицензии на этой странице#1

Этот курс научит вас основам языка программирования Ada и предназначен для тех, кто уже имеет базовое представление о методах программирования. Вы узнаете, как применить эти методы к программированию в Ada.

Этот документ был написан Рафаэлем Амьяром и Густаво А. Хоффманом с рецензией Ричарда Кеннера.

Contents:

- Введение

- История

- Ада сегодня

- Философия

- SPARK

- Императивы языка

- Hello world

- Условный оператор

- Циклы

- Циклы for

- Простой цикл

- Циклы while

- Оператор выбора

- Зоны описания

- Условные выражения

- Условное выражение

- Выражение выбора

- Подпрограммы

- Подпрограммы

- Вызовы подпрограмм

- Вложенные подпрограммы

- Вызов функций

- Виды параметров

- Вызов процедуры

- Параметры in

- Параметры in out

- Параметры out

- Предварительное объявление подпрограмм

- Переименование

- Модульное программирование

- Пакеты

- Использование пакета

- Тело пакета

- Дочерние пакеты

- Дочерний пакет от дочернего пакета

- Множественные потомки

- Видимость

- Переименование

- Сильно типизированный язык

- Что такое тип?

- Целочисленные типы - Integers

- Семантика операций

- Беззнаковые типы

- Перечисления

- Типы с плавающей запятой

- Основные свойства

- Точность типов с плавающей запятой

- Диапазон значений для типов с плавающей запятой

- Строгая типизация

- Производные типы

- Подтипы

- Подтипы в качестве псевдонимов типов

- Записи

- Объявление типа записи

- Агрегаты

- Извлечение компонент

- Переименование

- Массивы

- Объявление типа массива

- Доступ по индексу

- Более простые объявления массива

- Атрибут диапазона

- Неограниченные массивы

- Предопределенный тип String

- Ограничения

- Возврат неограниченных массивов

- Объявление массивов (2)

- Отрезки массива

- Переименование

- Подробнее о типах

- Агрегаты: краткая информация

- Cовмещение и квалифицированные выражения

- Символьные типы

- Ссылочные типы

- Введение

- Выделение (allocation) памяти

- Извлечение по ссылке

- Другие особенности

- Взаимно рекурсивные типы

- Подробнее о записях

- Типы записей динамически изменяемого размера

- Записи с дискриминантом

- Записи c вариантами

- Типы с фиксированной запятой

- Десятичные типы с фиксированной запятой

- Обычные типы с фиксированной запятой

- Изоляция

- Простейшая инкапсуляция

- Абстрактные типы данных

- Лимитируемые типы

- Дочерние пакеты и изоляция

- Настраиваемые модули

- Введение

- Объявление формального типа

- Объявление формального объекта

- Определение тела настраиваемого модуля

- Конкретизация настройки

- Настраиваемые пакеты

- Формальные подпрограммы

- Пример: конкретизация ввода/вывода

- Пример: АТД

- Пример: Обмен

- Пример: Обратный порядок элементов

- Пример: Тестовое приложение

- Исключения

- Объявление исключения

- Возбуждение исключения

- Обработка исключения

- Предопределенные исключения

- Управление задачами

- Задачи

- Простая задача

- Простая синхронизация

- Оператор задержки

- Синхронизация: рандеву

- Обрабатывающий цикл

- Циклические задачи

- Защищенные объекты

- Простой объект

- Входы

- Задачные и защищенные типы

- Задачные типы

- Защищенные типы

- Контрактное проектирование

- Пред- и постусловия

- Предикаты

- Инварианты типа

- Взаимодействие с языком C

- Многоязычный проект

- Соглашение о типах

- Подпрограммы на других языках

- Вызов подпрограмм C из Ады

- Вызов Ада подпрограмм из C

- Внешние переменные

- Использование глобальных переменных C в Аде

- Использование переменных Ада в C

- Автоматическое создание связок

- Адаптация связок

- Объектно-ориентированное программирование

- Производные типы

- Теговые типы

- Надклассовые типы

- Операции диспетчеризации

- Точечная нотация

- Личные и лимитируемые типы с тегами

- Надклассовые ссылочные типы

- Стандартная библиотека: Контейнеры

- Векторы

- Создание экземпляра

- Инициализация

- Добавление элементов

- Доступ к первому и последнему элементам

- Итерация

- Поиск и изменение элементов

- Вставка элементов

- Удаление элементов

- Другие операции

- Множества

- Инициализация и итерация

- Операции с элементами

- Другие операции

- Отображения для неопределенных типов

- Хэшированные отображения

- Упорядоченные отображения

- Сложность

- Стандартная библиотека: Дата и время

- Обработка даты и времени

- Задержка с использованием даты

- Режим реального времени

- Анализ производительности

- Стандартная библиотека: Строки

- Операции со строками

- Ограничение строк фиксированной длины

- Ограниченные строки

- Неограниченные строки

- Стандартная библиотека: Файлы и потоки

- Текстовый ввод-вывод

- Последовательный ввод-вывод

- Прямой ввод-вывод

- Потоковый ввод-вывод

- Стандартная библиотека: Numerics

- Элементарные функции

- Генерация случайных чисел

- Комплексные числа

- Работа с векторами и матрицами

- Приложения

- Приложение A: Формальные типы настройки

- Неопределенные версии типов

- Приложение B: Контейнеры

Footnotes

#1

http://creativecommons.org/licenses/by-sa/4.0

Введение

История

В 1970-х годах Министерство обороны Соединенных Штатов (МО) столкнулось с серьезной проблемой резкого увеличения числа языков программирования, заметив, что различные проекты использовали разные и нестандартные диалекты, языковые подмножества и расширения языков. Что бы решить эту проблему, Министерство обороны запустило конкурс на разработку нового современного языка программирования общего назначения. Победителем вышло предложение, представленное Жаном Ичбией из CII Honeywell-Bull.

Первый стандарт языка Ада был выпущен в 1983 году; впоследствии он был пересмотрен и усовершенствован в 1995, 2005 и 2012 годах, причем каждый пересмотр приносил новые полезные функции.

Этот учебник посвящен Ада 2012 в целом и не освещает различия прошлых версий языка.

Ада сегодня

Сегодня Ада широко используется во встраиваемых системах реального времени, во многих из которых критически важна надежность. Хотя Ада может использоваться в качестве языка общего назначения, он особенно подходит для низкоуровневых приложений:

- Встроенные системы с ограниченным объёмом памяти (сборщик мусора не допускается).

- Прямое взаимодействие с оборудованием.

- Мягкие или жесткие системы реального времени.

- Низкоуровневое системное программирование.

Конкретные области, в которых используется Ада, включают аэрокосмическую и оборонную промышленность, гражданскую авиацию, железную дорогу и многие другие. Эти приложения требуют высокой степени безопасности: дефект программного обеспечения не просто раздражает, но может иметь серьезные последствия. Язык Ада обладает свойствами благодаря которые возможно обнаружить дефекты на ранней стадии разработки — обычно во время компиляции или с помощью инструментов статического анализа. Язык Ада также можно использовать для создания приложений в различных других областях, таких как:

- Программирование видеоигр#1

- Аудио в реальном времени#2

- Модули ядра#3

Это неполный список, который, надеюсь, прольет свет на то, в каких сферах программирования хорош этот язык.

С точки зрения современных языков, наиболее близкими с точки зрения целей и уровня абстракции, вероятно, являются C++#4 и Rust#5.

Философия

Философия языка Ада отличается от большинства других языков. В основе дизайна Ада лежат принципы, среди которых можно выделить следующее:

- Удобочитаемость важнее краткости. Синтаксически это проявляется в том, что ключевые слова предпочтительнее символов, что ни одно ключевое слово не является аббревиатурой и т.д.

- Очень строгая типизация. В Аде очень легко вводить новые типы, что позволяет предотвратить ошибки использования данных.

- В этом отношении он похож на многие функциональные языки, за исключением того, что программист должен гораздо более четко описывать набор типов в Аде, потому что здесь почти не применяется вывод типов.

- Явное действие лучше, чем неявное. Хотя это заповедь языка Python#6, Ада идет дальше, чем любой известный нам язык:

- В большинстве случаев структурная типизация отсутствует, и программист должен явно именовать большинство типов.

- Как уже говорилось ранее, в основном нет вывода типов.

- Семантика очень чётко определена, а неопределенное поведение сведено к абсолютному минимуму.

- Обычно программист может предоставить компилятору (и другим программистам) много информации о свойствах его программы. Это позволяет компилятору быть чрезвычайно полезным (читай: строгим) программисту.

В ходе этого курса мы объясним отдельные языковые особенности, которые являются строительными блоками этой философии.

SPARK

Хотя этот курс посвящен исключительно языку Ада, стоит упомянуть, что существует еще один язык, чрезвычайно близкий к Аде и совместимый с ней: язык SPARK.

SPARK — это подмножество языка Ада, разработанное таким образом, что код, написанный на SPARK, поддается автоматической проверке. Это обеспечивает гораздо более высокий уровень уверенности в правильности вашего кода, чем при использовании обычного языка программирования.

Существует специальный курс для языка SPARK#7. Но следует иметь ввиду, когда мы говорим о мощи спецификаций языка Ада в этом курсе, можно усилить возможности этих спецификаций используя SPARK и доказать различные свойства программы, начиная с отсутствия ошибок во время выполнения до соответствия формально определенным функциональным требованиям.

Footnotes

#1

https://github.com/АдаDoom3/АдаDoom3

#2

http://www.electronicdesign.com/embedded-revolution/assessing-ada-language-audio-applications

#3

http://www.nihamkin.com/tag/kernel.html

#4

https://en.wikipedia.org/wiki/C%2B%2B

#5

https://www.rust-lang.org/en-US/

#6

https://www.python.org

#7

https://learn.adacore.com/courses/intro-to-spark/index.html

Императивы языка

Язык Ада поддерживает множество парадигм программирования, включая объектно-ориентированное программирование и некоторые элементы функционального программирования, но в его основе лежит простой сбалансированный процедурный/императивный язык, аналогичный C или Pascal.

На других языках

Одно важное различие между Адой и таким языком, как C, заключается в том, что операторы и выражения очень четко различаются. В Ада, если вы попытаетесь использовать выражение, там, где требуется оператор, ваша программа не будет скомпилированна. Это правило реализует полезный стилистический принцип: преднозначение выражений в вычислении значений, а не для в побочных эффектах. Оно также может предотвратить некоторые ошибки программирования, такие как ошибочное использование операции проверки на равенства = вместо операции присваивания := в операторе присваивания.

Hello world

Вот очень простая императивная программа Ада:

greet.adb

1with Ada.Text_IO;

2

3procedure Greet is

4begin

5   --  Print "Hello, World!" to the screen

6   Ada.Text_IO.Put_Line ("Hello, World!");

7end Greet;

Runtime output

Hello, World!

Текс программы, как мы предполагаем, находится в исходном файле greet.adb.

В вышеупомянутой программе есть несколько примечательных вещей:

- Подпрограмма в Аде может быть либо процедурой, либо функцией. Процедура, как показано выше, не возвращает значение при вызове.

- with используется для ссылки на внешние модули, которые необходимы в процедуре. Это похоже на import в разных языках или примерно похоже на #include в C и C++. Позже мы разберемся в деталях их работы. Здесь мы запрашиваем стандартный библиотечный модуль, пакет Ada.Text_IO, который содержит процедуру печати текста на экране: Put_Line.

- Greet - это процедура и основная точка входа в нашу первую программу. В отличие от C или C++, его можно назвать как угодно по вашему усмотрению. Построитель должен знать точку входа. В нашем простом примере gprbuild, построитель GNAT, будет использовать файл, который вы передали в качестве параметра.

- Put_Line - это такая же процедура, как и Greet, за исключением того, что она объявлена в модуле Ada.Text_IO. Это Ада-эквивалент printf в Си.

- Комментарии начинаются с -- и продолжаются до конца строки. Многострочные комментарии отсутствует, то есть невозможно начать комментарий в одной строке и продолжить его в следующей строке. Единственный способ создать несколько строк комментариев в Аде - это использовать "--" в каждой строке. Например:

--  We start a comment in this line...

--  and we continue on the second line...

На других языках

Процедуры аналогичны функциям в C или C++, которые возвращают значение void. Позже мы увидим, как объявлять функции в Аде.

Вот вариация примера «Hello, World»:

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4begin

5   --  Print "Hello, World!" to the screen

6   Put_Line ("Hello, World!");

7end Greet;

Runtime output

Hello, World!

В этой версии используется конструкция Аді, известное как спецификатор использования (use clause), которая имеет форму use имя-пакета. Как видно на вызове Put_Line, эффект заключается в том, что на объекты из указанного пакета можно ссылаться напрямую – нет необходимости использовать имя-пакета. как префикс.

Условный оператор

В этом разделе описывается условный оператор if в Аде, и вводятся некоторые другие основные возможности языка, такие как целочисленный ввод-вывод, объявления данных и виды параметров подпрограммы.

Условный оператор if в Аде довольно неудивителен по форме и функции:

check_positive.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

3

4procedure Check_Positive is

5   N : Integer;

6begin

7   --  Put a String

8   Put ("Enter an integer value: ");

9

10   --  Read in an integer value

11   Get (N);

12

13   if N > 0 then

14      --  Put an Integer

15      Put (N);

16      Put_Line (" is a positive number");

17   end if;

18end Check_Positive;

Оператор if в простейшей форме состоит из зарезервированного слова if, условия (которое должно быть логическим значением), зарезервированного слова then и непустой последовательности операторов (часть then), которая выполняется, если условие вычисляется как True, и окончивается end if.

Этот примере объявляет целочисленную переменную N, запрашивает у пользователя целое число, проверяет, является ли значение положительным, и, если да, отображается значение целого числа, за которым следует строка "является положительным числом" (is a positive number). Если значение не является положительным, то процедура не выводит ничего.

Тип Integer является предопределенным типом со знаком, и его диапазон зависит от архитектуры компьютера. На типичных современных процессорах целое число имеет 32-разрядный знак.

Пример иллюстрирует некоторые основные функциональные возможности для целочисленного ввода-вывода. Соответствующие подпрограммы находятся в предопределенном пакете Ada.Integer_Text_IO и включают процедуру Get (которая считывает число с клавиатуры) и процедуру Put (которая отображает целое значение).

Вот небольшое изменение в примере, которое иллюстрирует оператор if с частью else:

check_positive.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

3

4procedure Check_Positive is

5   N : Integer;

6begin

7   --  Put a String

8   Put ("Enter an integer value: ");

9

10   --  Reads in an integer value

11   Get (N);

12

13   --  Put an Integer

14   Put (N);

15

16   if N > 0 then

17      Put_Line (" is a positive number");

18   else

19      Put_Line (" is not a positive number");

20   end if;

21end Check_Positive;

В этом примере, если входное значение не является положительным, то программа отображает значение, за которым следует строка "не является положительным числом" (is not a positive number).

Наш последний вариант иллюстрирует оператор if с elsif частями:

check_direction.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

3

4procedure Check_Direction is

5   N : Integer;

6begin

7   Put ("Enter an integer value: ");

8   Get (N);

9   Put (N);

10

11   if N = 0 or N = 360 then

12      Put_Line (" is due north");

13   elsif N in 1 .. 89 then

14      Put_Line (" is in the northeast quadrant");

15   elsif N = 90 then

16      Put_Line (" is due east");

17   elsif N in 91 .. 179 then

18      Put_Line (" is in the southeast quadrant");

19   elsif N = 180 then

20      Put_Line (" is due south");

21   elsif N in 181 .. 269 then

22      Put_Line (" is in the southwest quadrant");

23   elsif N = 270 then

24      Put_Line (" is due west");

25   elsif N in 271 .. 359 then

26      Put_Line (" is in the northwest quadrant");

27   else

28      Put_Line (" is not in the range 0..360");

29   end if;

30end Check_Direction;

В этом примере ожидается, что пользователь введет целое число от 0 до 360 включительно, и отобразит, какому квадранту или оси соответствует значение. Операция in в Аде проверяет, находится ли скалярное значение в указанном диапазоне, и возвращает логический результат. Эффект программы должен быть очевиден; позже мы увидим альтернативный и более эффективный стиль для достижения того же эффекта используя оператор выбора case.

Ключевое слово elsif в Аде отличается от C или C ++, где вместо него будут использоваться блоки else .. if. И еще одно отличие - это наличие конца end if в Аде, что позволяет избежать проблемы, известной как «висящий else» (dangling else).

Циклы

У Ада есть три способа записи циклов. Каждый из них отличается от циклов for в C / Java / Javascript тем, что обладает более простыми синтаксисом и семантикой в соответствии с философией Ада.

Циклы for

Первый форма цикла - это цикл for, который позволяет выполнять итерацию по дискретному диапазону.

greet_5a.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet_5a is

4begin

5   for I in 1 .. 5 loop

6      --  Put_Line is a procedure call

7      Put_Line ("Hello, World!" & Integer'Image (I));

8      --        ^ Procedure parameter

9   end loop;

10end Greet_5a;

Runtime output

Hello, World! 1

Hello, World! 2

Hello, World! 3

Hello, World! 4

Hello, World! 5

Несколько моментов, которые следует отметить:

- 1 .. 5 - это дискретный диапазон, от 1 до 5 включительно.

- Параметр цикла I (имя произвольное) в теле цикла имеет значение в этом диапазоне.

- I является локальным для цикла, поэтому вы не можете ссылаться на I вне цикла.

- Хотя значение I увеличивается на каждой итерации, с точки зрения программы оно является константой. Попытка изменить его значение является незаконной; компилятор отклонит такую программу.

- Integer'Image - это функция, которая принимает целое число и преобразует его в строку. Это пример языковой конструкции, известной как атрибут, обозначенной синтаксисом ', который будет рассмотрен более подробно позже.

- Символ & является оператором конкатенации для строковых значений.

- end loop обозначает конец цикла

"Шаг" цикла ограничен 1 (направление вперед) и -1 (назад). Чтобы выполнить итерацию в обратном направлении по диапазону, используйте ключевое слово reverse:

greet_5a_reverse.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet_5a_Reverse is

4begin

5   for I in reverse 1 .. 5 loop

6      Put_Line ("Hello, World!"

7                & Integer'Image (I));

8   end loop;

9end Greet_5a_Reverse;

Runtime output

Hello, World! 5

Hello, World! 4

Hello, World! 3

Hello, World! 2

Hello, World! 1

Границы цикла for могут быть вычислены во время выполнения; они вычисляются один раз, перед выполнением тела цикла. Если значение верхней границы меньше значения нижней границы, то цикл вообще не выполняется. Это относится и к reverse циклам. Таким образом, в следующем примере вывод не производится:

greet_no_op.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet_No_Op is

4begin

5   for I in reverse 5 .. 1 loop

6      Put_Line ("Hello, World!"

7                & Integer'Image (I));

8   end loop;

9end Greet_No_Op;

Build output

greet_no_op.adb:5:23: warning: loop range is null, loop will not execute [enabled by default]

Цикл for имеет более общую форму, чем та, которую мы проиллюстрировали здесь; подробнее об этом позже.

Простой цикл

Самая простая форма цикла в Аде - это «голый» цикл, который образует основу других циклов Ада.

greet_5b.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet_5b is

4   --  Variable declaration:

5   I : Integer := 1;

6   --  ^ Type

7   --             ^ Initial value

8begin

9   loop

10      Put_Line ("Hello, World!"

11                & Integer'Image (I));

12

13      --  Exit statement:

14      exit when I = 5;

15      --        ^ Boolean condition

16

17      --  Assignment:

18      I := I + 1;

19      --  There is no I++ short form to

20      --  increment a variable

21   end loop;

22end Greet_5b;

Runtime output

Hello, World! 1

Hello, World! 2

Hello, World! 3

Hello, World! 4

Hello, World! 5

Этот пример имеет тот же эффект, что и Greet_5a, показанный ранее.

Он иллюстрирует несколько концепций:

- Мы объявили переменную с именем I между is и begin. Этот участок кода представляет собой зону описания. Ада чётко отделяет зону описания от секции операторов подпрограммы. Объявление может находиться в зоне описания, но не допускается в качестве оператора.

- Оператор простого цикла начинается с ключевого слова loop и, как и любой другой тип оператора цикла, завершается комбинацией ключевых слов end loop. Сам по себе это бесконечный цикл. Вы можете выйти из этого цикла с помощью оператора выхода exit.

- Синтаксис для присваивания :=, а синтаксис для равенства =. Их невозможно перепутать, потому что, как отмечалось ранее, в Аде операторы и выражения различны, а выражения не являются допустимыми операторами.

Циклы while

Последняя форма цикла в Аде - это цикл while.

greet_5c.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet_5c is

4   I : Integer := 1;

5begin

6   --  Condition must be a Boolean value

7   --  (no Integers).

8   --  Operator "<=" returns a Boolean

9   while I <= 5 loop

10      Put_Line ("Hello, World!"

11                & Integer'Image (I));

12

13      I := I + 1;

14   end loop;

15end Greet_5c;

Runtime output

Hello, World! 1

Hello, World! 2

Hello, World! 3

Hello, World! 4

Hello, World! 5

Условие вычисляется перед каждой итерацией. Если результат равен «ложь», то цикл завершается.

Эта программа имеет тот же эффект, что и предыдущие примеры.

На других языках

Обратите внимание, что Ада имеет иную семантику, чем языки на основе C, связанную с условием цикла while. В Ада условие должно быть логическим значением, иначе компилятор отклонит программу; условие не может быть целым числом, которое расценивается как истинное или ложное в зависимости от того, является ли оно ненулевым или нулевым.

Оператор выбора

Оператор выбора case в Аде аналогичен оператору switch из C/C++, но с некоторыми важными отличиями.

Вот пример, вариация программы, которая была показана ранее с инструкцией if:

check_direction.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

3

4procedure Check_Direction is

5   N : Integer;

6begin

7   loop

8      Put ("Enter an integer value: ");

9      Get (N);

10      Put (N);

11

12      case N is

13         when 0 | 360 =>

14            Put_Line (" is due north");

15         when 1 .. 89 =>

16            Put_Line (" is in the northeast quadrant");

17         when 90 =>

18            Put_Line (" is due east");

19         when 91 .. 179 =>

20            Put_Line (" is in the southeast quadrant");

21         when 180 =>

22            Put_Line (" is due south");

23         when 181 .. 269 =>

24            Put_Line (" is in the southwest quadrant");

25         when 270 =>

26            Put_Line (" is due west");

27         when 271 .. 359 =>

28            Put_Line (" is in the northwest quadrant");

29         when others =>

30            Put_Line (" Au revoir");

31            exit;

32      end case;

33   end loop;

34end Check_Direction;

Эта программа неоднократно запрашивает целочисленное значение, а затем, если значение находится в диапазоне 0 .. 360, отображает соответствующий квадрант или ось. Если значение является целым числом за пределами этого диапазона, цикл (и программа) завершаются после вывода прощального сообщения.

Эффект оператора выбора аналогичен условному оператору в предыдущем примере, но оператор выбора может быть более эффективным, нет нужды выполнять несколько тестов диапазона.

Примечательные моменты в операторе выбора в Аде:

- Выражение выбора (здесь переменная N) должно быть дискретного типа, то есть либо целочисленного типа, либо типа перечисления. Дискретные типы будут рассмотрены более подробно позже.

- Каждое возможное значение для выражения выбора должно быть охвачено уникальной ветвью оператора case. Это будет проверено во время компиляции.

- Ветвь может указывать одно значение, например 0; диапазон значений, например 1 .. 89; или любая их комбинация (с разделителем |).

- Отдельно может быть задана конечная ветвь с ключевым словом others, которая охватывает все значения, не включенные в предыдущие ветки.

- Выполнение состоит из вычисления выражения выбора, а затем передачи управления последовательности инструкций в уникальной ветви, которая охватывает это значение.

- Когда выполнение операторов в выбранной ветви завершено, управление возобновляется после последней ветви (после end case). В отличие от C, выполнение не попадает в следующую ветвь. Таким образом, в Аде не нужен (и не существует) оператор break.

Зоны описания

Как упоминалось ранее, Ада проводит четкое синтаксическое разделение между объявлениями, которые вводят имена для сущностей, которые будут использоваться в программе, и операторами, выполняющими обработку. Области в программе, в которых могут появляться объявления, называются зонами описания.

В любой подпрограмме участок кода между is и begin является зоной описания. Там могут быть переменные, константы, типы, внутренние подпрограммы и другие сущности.

Мы кратко упоминали объявления переменных в предыдущем подразделе. Давайте посмотрим на простой пример, где мы объявляем целочисленную переменную X в зоне описания и выполняем инициализацию и добавление к ней единицы:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4   X : Integer;

5begin

6   X := 0;

7   Put_Line ("The initial value of X is "

8             & Integer'Image (X));

9

10   Put_Line ("Performing operation on X...");

11   X := X + 1;

12

13   Put_Line ("The value of X now is "

14             & Integer'Image (X));

15end Main;

Runtime output

The initial value of X is  0

Performing operation on X...

The value of X now is  1

Давайте рассмотрим пример вложенной процедуры:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4   procedure Nested is

5   begin

6      Put_Line ("Hello World");

7   end Nested;

8begin

9   Nested;

10   --  Call to Nested

11end Main;

Runtime output

Hello World

Объявление не может использоваться как оператор. Если вам нужно объявить локальную переменную среди операторов, вы можете ввести новую зону описания с помощью блочного оператора:

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4begin

5   loop

6      Put_Line ("Please enter your name: ");

7

8      declare

9         Name : String := Get_Line;

10         --               ^ Call to the

11         --                 Get_Line function

12      begin

13         exit when Name = "";

14         Put_Line ("Hi " & Name & "!");

15      end;

16

17      --  Name is undefined here

18   end loop;

19

20  Put_Line ("Bye!");

21end Greet;

Build output

greet.adb:9:10: warning: "Name" is not modified, could be declared constant [-gnatwk]

Attention

Функция Get_Line позволяет получать входные данные от пользователя и выдавать результат в виде строки. Это более или менее эквивалентно функции scanf C.

Она возвращает строку (типа String), которая, как мы увидим позже, является неограниченным типом массива. Пока мы просто отмечаем, что, если вы хотите объявить строковую переменную (с типом String) и заранее не знаете ее размер, вам необходимо инициализировать переменную во время ее объявления.

Условные выражения

В Ада 2012 были введены выражения-аналоги условных операторов (if и case).

Условное выражение

Вот альтернативная версия примера приведённого выше; операторы if заменены на if выражения:

check_positive.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

3

4procedure Check_Positive is

5   N : Integer;

6begin

7   Put ("Enter an integer value: ");

8   Get (N);

9   Put (N);

10

11   declare

12      S : constant String :=

13        (if N > 0 then " is a positive number"

14         else " is not a positive number");

15   begin

16      Put_Line (S);

17   end;

18end Check_Positive;

Выражение if вычисляет одну из двух строк в зависимости от N и присваивает это значение локальной переменной S.

Выражения if в Аде аналогичны операторам if. Однако есть несколько отличий, следующих из того факта, что это выражение:

- Выражения всех ветвей должны быть одного типа

- Оно должно быть заключено в круглые скобки, если уже не охвачено ими

- Ветвь else обязательна, если только следующее за then выражение не имеет логического значения. В этом случае ветвь else является необязательной и, если она отсутствует, по умолчанию аналогична else True.

Вот еще один пример:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4begin

5   for I in 1 .. 10 loop

6      Put_Line (if I mod 2 = 0 then "Even" else "Odd");

7   end loop;

8end Main;

Runtime output

Odd

Even

Odd

Even

Odd

Even

Odd

Even

Odd

Even

Эта программа выдает 10 строк вывода, чередующихся слов "Нечетный" и "Четный" ("Odd" и "Even").

Выражение выбора

Аналогично выражениям if, в Аде также есть выражения case. Они работают именно так, как вы и ожидали.

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4begin

5   for I in 1 .. 10 loop

6      Put_Line (case I is

7                when 1 | 3 | 5 | 7 | 9 => "Odd",

8                when 2 | 4 | 6 | 8 | 10 => "Even");

9   end loop;

10end Main;

Runtime output

Odd

Even

Odd

Even

Odd

Even

Odd

Even

Odd

Even

Эта программа имеет тот же эффект, что и в предыдущем примере.

Синтаксис отличается от операторов case тем, что ветви разделены запятыми.

Footnotes

Подпрограммы

Подпрограммы

До сих пор мы использовали процедуры, в основном, чтобы расположить там кода для исполнения. Процедуры являются одним из видов подпрограмм.

В Аде есть два вида подпрограмм: функции и процедуры. Различие между ними заключается в том, что функция возвращает значение, а процедура - нет.

В этом примере показано объявление и определение функции:

increment.ads

1function Increment (I : Integer) return Integer;

increment.adb

1--  We declare (but don't define) a function with

2--  one parameter, returning an integer value

3

4function Increment (I : Integer) return Integer is

5   --  We define the Increment function

6begin

7    return I + 1;

8end Increment;

Подпрограммы в Аде, конечно, могут иметь параметры. Одно важное замечание касающееся синтаксиса заключается в том, что подпрограмма, у которой нет параметров, вообще не имеет раздела параметров, например:

procedure Proc;

function Func return Integer;

Вот еще один вариант предыдущего примера:

increment_by.ads

1function Increment_By

2  (I    : Integer := 0;

3   Incr : Integer := 1) return Integer;

4--                ^ Default value for parameters

В этом примере мы видим, что параметры могут иметь значения по умолчанию. При вызове подпрограммы вы можете опустить параметры, если они имеют значение по умолчанию. В отличие от C/C++, вызов подпрограммы без параметров не использует скобки.

Вот реализация функции, описанной выше:

increment_by.adb

1function Increment_By

2  (I    : Integer := 0;

3   Incr : Integer := 1) return Integer is

4begin

5   return I + Incr;

6end Increment_By;

В наборе инструментов GNAT

Стандарт языка Ада не регламентирует в каких файлах следует расположить спецификацию и тело подпрограммы. Другими словами, стандарт не навязывает какую-либо структуру организации файлов или расширения имен файлов. К примеру, мы могли бы сохранить и спецификацию и тело указаной выше функции Increment в файле с названием increment.txt. (Мы даже могли бы поместить весь исходный код системы в один файл.) С точки зрения стандарта это вполне допустимо.

С другой стороны, набор инструментов GNAT требует следующую схему наименования файлов:

- файлы с расширением .ads содержат спецификацию, тогда, как

- файлы с расширением .adb содержат реализацию.

Таким образом, для инструментария GNAT, спецификация функции Increment должна находиться в файле increment.ads, а ее реализация должна находиться в файле increment.adb. Это правило также применяется для пакетов, которые мы обсудим позже. (Отметим, однако, что это правило можно обойти.) Дополнительные детали смотрите в курсе Introduction to GNAT Toolchain#1 или в GPRbuild User’s Guide#2.

Вызовы подпрограмм

Далее мы можем вызвать нашу подпрограмму следующим образом:

show_increment.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Increment_By;

3

4procedure Show_Increment is

5   A, B, C : Integer;

6begin

7   C := Increment_By;

8   --              ^ Parameterless call,

9   --                value of I is 0

10   --                and Incr is 1

11

12   Put_Line ("Using defaults for Increment_By is "

13             & Integer'Image (C));

14

15   A := 10;

16   B := 3;

17   C := Increment_By (A, B);

18   --                 ^ Regular parameter passing

19

20   Put_Line ("Increment of "

21             & Integer'Image (A)

22             & " with "

23             & Integer'Image (B)

24             & " is "

25             & Integer'Image (C));

26

27   A := 20;

28   B := 5;

29   C := Increment_By (I    => A,

30                      Incr => B);

31    --                ^ Named parameter passing

32

33   Put_Line ("Increment of "

34             & Integer'Image (A)

35             & " with "

36             & Integer'Image (B)

37             & " is "

38             & Integer'Image (C));

39end Show_Increment;

Runtime output

Using defaults for Increment_By is  1

Increment of  10 with  3 is  13

Increment of  20 with  5 is  25

Ада позволяет вам выполнять указывать имена параметров при передачи их во время вызова, независимо от того, есть ли значения по умолчанию или нет. Но есть несколько правил:

- Позиционные параметры должны идти первыми.

- Позиционный параметр не может следовать за именованным параметром.

Как правило, пользователи используют именованные параметры во время вызова, если соответствующий параметр функции имеет значение по умолчанию. Однако также вполне приветствуется использовать вызов с именованием каждого параметра, если это делает код более понятным.

Вложенные подпрограммы

Как кратко упоминалось ранее, Ада позволяет вам объявлять одну подпрограмму внутри другой.

Это полезно по двум причинам:

- Это позволяет вам получить более понятную программу. Если вам нужна подпрограмма только как «помощник» для другой подпрограммы, то принцип локализации указывает, что подпрограмма-помощник должна быть объявлена вложенной.

- Это облегчает вам доступ к данным объемлющей подпрограммы и сохранить при этом контроль, потому что вложенные подпрограммы имеют доступ к параметрам, а также к любым локальным переменным, объявленным во внешней области.

Используя предыдущий пример, можно переместить часть кода (вызов Put_Line) в отдельную процедуру и избежать дублирования. Вот укороченная версия с вложенной процедурой Display_Result:

show_increment.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Increment_By;

3

4procedure Show_Increment is

5   A, B, C : Integer;

6

7   procedure Display_Result is

8   begin

9      Put_Line ("Increment of "

10                & Integer'Image (A)

11                & " with "

12                & Integer'Image (B)

13                & " is "

14                & Integer'Image (C));

15   end Display_Result;

16

17begin

18   A := 10;

19   B := 3;

20   C := Increment_By (A, B);

21   Display_Result;

22end Show_Increment;

Runtime output

Increment of  10 with  3 is  13

Вызов функций

Важной особенностью вызовов функций в Аде является то, что возвращаемое значение при вызове нельзя игнорировать; то есть вызов функции не может использоваться как оператор.

Если вы хотите вызвать функцию и вам не нужен ее результат, вам все равно нужно будет явно сохранить его в локальной переменной.

quadruple.adb

1function Quadruple (I : Integer) return Integer is

2    function Double (I : Integer) return Integer is

3    begin

4       return I * 2;

5    end Double;

6

7   Res : Integer := Double (Double (I));

8   --               ^ Calling the Double

9   --                 function

10begin

11   Double (I);

12   --  ERROR: cannot use call to function

13   --         "Double" as a statement

14

15   return Res;

16end Quadruple;

Build output

quadruple.adb:11:04: error: cannot use call to function "Double" as a statement

quadruple.adb:11:04: error: return value of a function call cannot be ignored

gprbuild: *** compilation phase failed

В наборе инструментов GNAT

В GNAT, когда все предупреждения активированы, становится еще сложнее игнорировать результат функции, потому что неиспользуемые переменные будут выявлены. Например, этот код будет недействительным:

function Read_Int

(Stream :     Network_Stream;

Result : out Integer) return Boolean;

procedure Main is

Stream : Network_Stream := Get_Stream;

My_Int : Integer;

-- Warning: in the line below, B is

--          never read.

B : Boolean := Read_Int (Stream, My_Int);

begin

null;

end Main;

Затем у вас есть два решения, чтобы отключить это предупреждение:

- Либо аннотировать переменную с помощью pragma Unreferenced, таким образом:

B : Boolean := Read_Int (Stream, My_Int);

pragma Unreferenced (B);

- Или дайть переменной имя, которое содержит любую из строк: discard dummy ignore junk unused (без учета регистра)

Виды параметров

До сих пор мы видели, что Ада - это язык, ориентированный на безопасность. Существует много механизмов реализации этого принципа, но два важных момента заключаются в следующем:

- Ада позволяет пользователю как можно более точно указать ожидаемое поведение программы, чтобы компилятор мог предупреждать или отклонять при обнаружении несоответствия.

- Ада предоставляет множество методов для достижения общности и гибкости указателей и динамического управления памятью, но без недостатков последнего (таких как утечка памяти и висячие ссылки).

Виды параметров - это возможность, которая помогает воплотить эти два момента на практике. Параметр подпрограммы может быть одного из следующих видов:

in

Параметр может быть только считан, но не записан

out

Параметр можно записать, а затем прочитать

in out

Параметр может быть, как считан, так и записан

По умолчанию вид параметра будет in; до сих пор большинство примеров использовали параметры вида in.

Исторически

Функции и процедуры изначально были более разными по философии. До Ада 2012 функции могли принимать только «входящие» (in) параметры.

Вызов процедуры

Параметры in

Первый вид параметра - это тот, который мы неявно использовали до сих пор. Параметры этого вида нельзя изменить, поэтому следующая программа вызовет ошибку:

swap.adb

1procedure Swap (A, B : Integer) is

2   Tmp : Integer;

3begin

4   Tmp := A;

5

6   --  Error: assignment to "in" mode

7   --         parameter not allowed

8   A := B;

9

10   --  Error: assignment to "in" mode

11   --         parameter not allowed

12   B := Tmp;

13end Swap;

Build output

swap.adb:8:04: error: assignment to "in" mode parameter not allowed

swap.adb:12:04: error: assignment to "in" mode parameter not allowed

gprbuild: *** compilation phase failed

Тот факт, что это вид используется по умолчанию, сам по себе очень важен. Это означает, что параметр не будет изменен, если вы явно не укажете ему другой вид, для которого разрешено изменение.

Параметры in out

Для исправления кода, приведенного выше, можно использовать параметр in out .

in_out_params.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure In_Out_Params is

4   procedure Swap (A, B : in out Integer) is

5      Tmp : Integer;

6   begin

7      Tmp := A;

8      A   := B;

9      B   := Tmp;

10   end Swap;

11

12   A : Integer := 12;

13   B : Integer := 44;

14begin

15    Swap (A, B);

16

17    --  Prints 44

18    Put_Line (Integer'Image (A));

19end In_Out_Params;

Runtime output

44

Параметр in out обеспечивает доступ для чтения и записи к объекту, переданному в качестве параметра, поэтому в приведенном выше примере видно, что значение A изменяется после вызова функции Swap.

Attention

В то время как параметры in out немного похожи на ссылки в C++ или обычные параметры в Java, которые передаются по ссылке, стандарт языка Ада не требует передачи параметров in out "по ссылке", за исключением определенных категорий типов, как будет объяснено позже.

В общем, лучше думать о видах параметров как о более высоком уровне, чем о семантике «по значению» или «по ссылке». Для компилятора это означает, что массив, передаваемый в качестве параметра in, может передаваться по ссылке, поскольку это более эффективено (что ничего не меняет для пользователя, поскольку параметр не может быть назначен). Однако параметр дискретного типа всегда будет передаваться копией, независимо от его вида (ведь так более эффективено на большинстве архитектур).

Параметры out

Вид «out» применяется, когда подпрограмме необходимо выполнить запись в параметр, который может быть не инициализирован в момент вызова. Чтение значения выходного параметра разрешено, но оно должно выполняться только после того, как подпрограмма присвоила значение параметру. Параметры out немного похожи на возвращаемые значения функций. Когда подпрограмма возвращается, фактический параметр (переменная) будет иметь значение параметра в точке возврата.

На других языках

Ада не имеет конструкции кортежа и не позволяет возвращать несколько значений из подпрограммы (за исключением объявления полноценного типа записи). Следовательно, способ вернуть несколько значений из подпрограммы состоит в использовании параметров out.

Например, процедура считывания целых чисел из сети может иметь одну из следующих спецификаций:

procedure Read_Int

(Stream  :     Network_Stream;

Success : out Boolean;

Result  : out Integer);

function Read_Int

(Stream :     Network_Stream;

Result : out Integer) return Boolean;

При чтении переменной out до записью в нее в идеале должна возникать ошибка, но, если бы было введено такое правило, то это бы привело либо к неэффективным проверкам во время выполнения, либо к очень сложным правилам во время компиляции. Таким образом, с точки зрения пользователя параметр out действует как неинициализированная в момент вызова подпрограммы переменная.

В наборе инструментов GNAT

GNAT обнаружит простые случаи неправильного использования параметров out. Например, компилятор выдаст предупреждение для следующей программы:

outp.adb

1procedure Outp is

2   procedure Foo (A : out Integer) is

3      B : Integer := A;

4      --             ^ Warning on reference

5      --               to uninitialized A

6   begin

7      A := B;

8   end Foo;

9begin

10   null;

11end Outp;

Build output

outp.adb:2:14: warning: procedure "Foo" is not referenced [-gnatwu]

outp.adb:3:07: warning: "B" is not modified, could be declared constant [-gnatwk]

outp.adb:3:22: warning: "A" may be referenced before it has a value [enabled by default]

Предварительное объявление подпрограмм

Как мы видели ранее, подпрограмма может быть объявлена без полного определения. Это возможно в целом и может быть полезно, если вам нужно, чтобы подпрограммы были взаимно рекурсивными, как в примере ниже:

mutually_recursive_subprograms.adb

1procedure Mutually_Recursive_Subprograms is

2    procedure Compute_A (V : Natural);

3    --  Forward declaration of Compute_A

4

5    procedure Compute_B (V : Natural) is

6    begin

7       if V > 5 then

8          Compute_A (V - 1);

9          --  Call to Compute_A

10       end if;

11    end Compute_B;

12

13    procedure Compute_A (V : Natural) is

14    begin

15       if V > 2 then

16          Compute_B (V - 1);

17          --  Call to Compute_B

18       end if;

19    end Compute_A;

20begin

21   Compute_A (15);

22end Mutually_Recursive_Subprograms;

Переименование

Подпрограммы можно переименовать, используя ключевое слово renames и объявив новое имя для подпрограммы:

procedure New_Proc renames Original_Proc;

Это может быть полезно, например, для улучшения читаемости вашей программы, когда вы используете код из внешних источников, который нельзя изменить в вашей системе. Давайте посмотрим на пример:

a_procedure_with_very_long_name_that_cannot_be_changed.ads

1procedure A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed

2  (A_Message : String);

a_procedure_with_very_long_name_that_cannot_be_changed.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed

4  (A_Message : String) is

5begin

6   Put_Line (A_Message);

7end A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed;

Как следует из названия процедуры, мы не можем изменить его. Однако мы можем переименовать процедуру во что-то вроде Show в нашем тестовом приложении и использовать это более короткое имя. Обратите внимание, что мы также должны объявить все параметры исходной подпрограммы, но мы можем именовать их по другому при объявлении. Например:

show_renaming.adb

1with A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed;

2

3procedure Show_Renaming is

4

5   procedure Show (S : String) renames

6     A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed;

7

8begin

9   Show ("Hello World!");

10end Show_Renaming;

Runtime output

Hello World!

Обратите внимание, что исходное имя (A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed) по-прежнему остается доступно после объявления процедуры Show.

Можно также переименовать подпрограммы из стандартной библиотеки. Например, можно переименовать Integer'Image в Img:

show_image_renaming.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Image_Renaming is

4

5   function Img (I : Integer) return String

6     renames Integer'Image;

7

8begin

9   Put_Line (Img (2));

10   Put_Line (Img (3));

11end Show_Image_Renaming;

Runtime output

2

3

Переименование также позволяет вводить выражения по умолчанию, которые не были указаны в исходном объявлении. Например, можно задать "Hello World!" в качестве значения по умолчанию для параметра String процедуры Show:

with A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed;

procedure Show_Renaming_Defaults is

procedure Show (S : String := "Hello World!")

renames

A_Procedure_With_Very_Long_Name_That_Cannot_Be_Changed;

begin

Show;

end Show_Renaming_Defaults;

Footnotes

#1

https://learn.adacore.com/courses/GNAT_Toolchain_Intro/index.html

#2

https://docs.adacore.com/gprbuild-docs/html/gprbuild_ug.html

Модульное программирование

До сих пор наши примеры были простыми автономными подпрограммами. Возможность расположить произвольные объявления в зоне описания способствует этому. Благодоря этой возможности мы смогли объявить наши типы и переменные в телах основных процедур.

Однако легко увидеть, что такой подход не вписывается в масштаб реальных приложений. Нам нужен лучший способ структурировать наши программы в модульные и отдельные блоки.

Ада поощряет разделение программ на несколько пакетов и подпакетов, предоставляя программисту множество инструментов в поисках идеальной организации кода.

Пакеты

Вот пример объявления пакета в Аде:

week.ads

1package Week is

2

3   Mon : constant String := "Monday";

4   Tue : constant String := "Tuesday";

5   Wed : constant String := "Wednesday";

6   Thu : constant String := "Thursday";

7   Fri : constant String := "Friday";

8   Sat : constant String := "Saturday";

9   Sun : constant String := "Sunday";

10

11end Week;

А вот как вы его используете:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Week;

3--  References the Week package, and

4--  adds a dependency from Main to Week

5

6procedure Main is

7begin

8   Put_Line ("First day of the week is "

9             & Week.Mon);

10end Main;

Runtime output

First day of the week is Monday

Пакеты позволяют вам сделать код модульным, разбивая программы на семантически значимые единицы. Кроме того, отделение спецификации пакета от его тела (которое мы увидим ниже) может сократить время компиляции.

Хотя спецификатор контекста with указывает зависимость, в приведенном выше примере видно, что нам всё еще нужно использовать префикс с менем пакета, чтобы сослаться на имя в этом пакете. (Если бы мы также указали спецификатор использования use Week, то такой префикс уже не был бы необходим.)

При доступе к объектам из пакета используется точечная нотация A.B, аналогичная той, что используется для доступа к полям записей.

Спецификатор контекста with может появляться только в начале модуля компиляции (т. е. перед зарезервированным словом, таким как procedure, которое отмечает начало модуля). В других местах он запрещен. Это правило необходимо только по методологическим соображениям: человек, читающий ваш код, должен сразу видеть, от каких модулей он зависит.

На других языках

Пакеты похожи на файлы заголовков в C / C ++, но семантически сильно отличаются от них.

- Первое и самое важное отличие состоит в том, что пакеты представляют собой механизм уровня языка. В то время, как заголовочный файл из #include обрабатывается препроцессором C.

- Непосредственным следствием этого является то, что конструкция with работает на семантическом уровне, а не с помощью подстановки текста. Следовательно, когда вы работаете с пакетом указывая with, вы говорите компилятору: «Я зависим от этой семантической единицы», а не «включите сюда эту кучу текста».

- Таким образом, действие пакета не зависит от того, откуда на него ссылается with. Сравните это с C/C++, где смысл включенного текста может меняться в зависимости от контекста, в котором появляется #include.

Это позволяет повысить эффективность компиляции/перекомпиляции. Это также облегчает инструментам, таким как IDE, получать правильную информацию о семантике программы. Что, в свою очередь, позволяет иметь лучший инструментарий в целом и код, который легче поддается анализу даже людьми.

Важным преимуществом with в Аде по сравнению с #include является то, что он не имеет состояния. Порядок спецификаторов with и use не имеет значения и может быть изменен без побочных эффектов.

В наборе инструментов GNAT

Стандарт языка Ада не предусматривает каких-либо особых отношений между исходными файлами и пакетами; например, теоретически вы можете поместить весь свой код в один файл или использовать свои собственные соглашения об именовании файлов. На практике, однако, каждая реализация имеет свои правила. Для GNAT каждый модуль компиляции верхнего уровня должен быть помещен в отдельный файл. В приведенном выше примере пакет Week будет находиться в файле .ads (для Ада спецификации), а основная процедура Main - в файле .adb (для Ада тела).

Использование пакета

Как мы видели выше, спецификатор контекста with указывает на зависимость от другого пакета. Тем не менее, каждая ссылка на сущъность, находящуюся в пакете Week, должна иметь префикс в виде полного имени пакета. Можно сделать все сущъности пакета непосредственно видимым в текущей области с помощью спецификатора использования use.

Фактически, мы использовали спецификатор use почти с самого начала этого руководства.

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2--                ^ Make every entity of the

3--                  Ada.Text_IO package

4--                  directly visible.

5with Week;

6

7procedure Main is

8   use Week;

9   --  Make every entity of the Week

10   --  package directly visible.

11begin

12   Put_Line ("First day of the week is " & Mon);

13end Main;

Runtime output

First day of the week is Monday

Как вы можете видеть в приведенном выше примере:

- Put_Line - это подпрограмма из пакета Ada.Text_IO. Мы можем ссылаться на нее непосредственно, потому что мы указали пакет в use в верхней части основного модуля Main.

- В отличие от спецификатора контекста with, спецификатор использования use может быть помещен либо в заголовок, либо в любую область описания. В последнем случае эффект use будет распространяться только на соответствующую область видимости.

Тело пакета

В приведенном выше простом примере пакет Week содержит только объявления и не содержит реализаций. Это не ошибка: в спецификации пакета, которая проиллюстрирована выше, нельзя объявлять реализации. Реализации должны находиться в теле пакета.

operations.ads

1package Operations is

2

3   --  Declaration

4   function Increment_By

5     (I    : Integer;

6      Incr : Integer := 0) return Integer;

7

8   function Get_Increment_Value return Integer;

9

10end Operations;

operations.adb

1package body Operations is

2

3   Last_Increment : Integer := 1;

4

5   function Increment_By

6     (I    : Integer;

7      Incr : Integer := 0) return Integer is

8   begin

9      if Incr /= 0 then

10         Last_Increment := Incr;

11      end if;

12

13      return I + Last_Increment;

14   end Increment_By;

15

16   function Get_Increment_Value return Integer is

17   begin

18      return Last_Increment;

19   end Get_Increment_Value;

20

21end Operations;

Здесь мы видим, что тело функции Increment_By должно быть объявлено в теле. Пользуясь появлением тела можно поместить переменную Last_Increment в тело, и сделать ее недоступной для пользователя пакета Operations, обеспечив первую форму инкапсуляции.

Это работает, поскольку объекты, объявленные в теле, видимы только в теле.

В этом примере показано, как непосредственно использовать Increment_By:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Operations;

3

4procedure Main is

5   use Operations;

6

7   I : Integer := 0;

8   R : Integer;

9

10   procedure Display_Update_Values is

11      Incr : constant Integer := Get_Increment_Value;

12   begin

13      Put_Line (Integer'Image (I)

14                & " incremented by "

15                & Integer'Image (Incr)

16                & " is "

17                & Integer'Image (R));

18      I := R;

19   end Display_Update_Values;

20begin

21   R := Increment_By (I);

22   Display_Update_Values;

23   R := Increment_By (I);

24   Display_Update_Values;

25

26   R := Increment_By (I, 5);

27   Display_Update_Values;

28   R := Increment_By (I);

29   Display_Update_Values;

30

31   R := Increment_By (I, 10);

32   Display_Update_Values;

33   R := Increment_By (I);

34   Display_Update_Values;

35end Main;

Runtime output

0 incremented by  1 is  1

1 incremented by  1 is  2

2 incremented by  5 is  7

7 incremented by  5 is  12

12 incremented by  10 is  22

22 incremented by  10 is  32

Дочерние пакеты

Пакеты можно использовать для создания иерархий. Мы достигаем этого с помощью дочерних пакетов, которые расширяют функциональность родительского пакета. Одним из примеров дочернего пакета, который мы использовали до сих пор, является пакет Ada.Text_IO. Здесь родительский пакет называется Ada, а дочерний пакет называется Text_IO. В предыдущих примерах мы использовали процедуру Put_Line из дочернего пакета Text_IO.

Важное замечание

Ада также поддерживает вложенные пакеты. Однако, поскольку их использование может быть более сложным, рекомендуется использовать дочерние пакеты. Вложенные пакеты будут рассмотрены в расширенном курсе.

Давайте начнем обсуждение дочерних пакетов с нашего предыдущего пакета Week:

week.ads

1package Week is

2

3   Mon : constant String := "Monday";

4   Tue : constant String := "Tuesday";

5   Wed : constant String := "Wednesday";

6   Thu : constant String := "Thursday";

7   Fri : constant String := "Friday";

8   Sat : constant String := "Saturday";

9   Sun : constant String := "Sunday";

10

11end Week;

Если мы хотим создать дочерний пакет для Week, мы можем написать:

week-child.ads

1package Week.Child is

2

3   function Get_First_Of_Week return String;

4

5end Week.Child;

Здесь Week - это родительский пакет, а Child - дочерний. Это соответствующее тело пакета Week.Child:

week-child.adb

1package body Week.Child is

2

3   function Get_First_Of_Week return String is

4   begin

5      return Mon;

6   end Get_First_Of_Week;

7

8end Week.Child;

В реализации функции Get_First_Of_Week мы можем использовать строку Mon непосредственно, хотя она объявлена в родительском пакете Week. Мы не пишем здесь with Week, потому что все элементы из спецификации пакета Week, такие как Mon, Tue и т. д., видны в дочернем пакете Week.Child.

Теперь, когда мы завершили реализацию пакета Week.Child, мы можем использовать элементы из этого дочернего пакета в подпрограмме, просто написав with Week.Child. Точно так же, если мы хотим использовать эти элементы непосредственно, мы дополнительно напишем use Week.Child. Например:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Week.Child;  use Week.Child;

3

4procedure Main is

5begin

6   Put_Line ("First day of the week is "

7             & Get_First_Of_Week);

8end Main;

Runtime output

First day of the week is Monday

Дочерний пакет от дочернего пакета

До сих пор мы видели двухуровневую иерархию пакетов. Но иерархия, которую мы потенциально можем создать, этим не ограничивается. Например, мы могли бы расширить иерархию предыдущего примера исходного кода, объявив пакет Week.Child.Grandchild. В этом случае Week.Child будет родительским для пакета Grandchild. Рассмотрим эту реализацию:

week-child-grandchild.ads

1package Week.Child.Grandchild is

2

3   function Get_Second_Of_Week return String;

4

5end Week.Child.Grandchild;

week-child-grandchild.adb

1package body Week.Child.Grandchild is

2

3   function Get_Second_Of_Week return String is

4   begin

5      return Tue;

6   end Get_Second_Of_Week;

7

8end Week.Child.Grandchild;

Мы можем использовать этот новый пакет Grandchild в нашем тестовом приложении так же, как и раньше: мы можем повторно использовать предыдущее тестовое приложение адаптировав with, use и вызов функции. Вот обновленный код:

main.adb

1with Ada.Text_IO;           use Ada.Text_IO;

2with Week.Child.Grandchild; use Week.Child.Grandchild;

3

4procedure Main is

5begin

6   Put_Line ("Second day of the week is "

7             & Get_Second_Of_Week);

8end Main;

Runtime output

Second day of the week is Tuesday

Опять же, это не предел иерархии пакетов. Мы могли бы продолжить расширение иерархии предыдущего примера, реализовав пакет Week.Child.Grandchild.Grand_grandchild.

Множественные потомки

До сих пор мы видели лишь один дочерний пакет родительского пакета. Однако родительский пакет также может иметь несколько дочерних. Мы могли бы расширить приведенный выше пример и создать пакет Week.Child_2. Например:

week-child_2.ads

1package Week.Child_2 is

2

3   function Get_Last_Of_Week return String;

4

5end Week.Child_2;

Здесь Week по-прежнему является родительским пакетом для пакета Child, но также родительским пакетом и для пакета Child_2. Таким же образом, Child_2, очевидно, является одним из дочерних пакетов Week.

Это соответствующее тело пакета Week.Child_2:

week-child_2.adb

1package body Week.Child_2 is

2

3   function Get_Last_Of_Week return String is

4   begin

5      return Sun;

6   end Get_Last_Of_Week;

7

8end Week.Child_2;

Теперь мы можем сослаться на оба потомка в нашем тестовом приложении:

main.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Week.Child;   use Week.Child;

3with Week.Child_2; use Week.Child_2;

4

5procedure Main is

6begin

7   Put_Line ("First day of the week is "

8             & Get_First_Of_Week);

9   Put_Line ("Last day of the week is "

10             & Get_Last_Of_Week);

11end Main;

Runtime output

First day of the week is Monday

Last day of the week is Sunday

Видимость

В предыдущем разделе мы видели, что элементы, объявленные в спецификации родительского пакета, видны в дочернем пакете. Однако это не относится к элементам, объявленным в теле родительского пакета.

Рассмотрим пакет Book и его дочерний элемент Additional_Operations:

book.ads

1package Book is

2

3   Title : constant String :=

4     "Visible for my children";

5

6   function Get_Title return String;

7

8   function Get_Author return String;

9

10end Book;

book-additional_operations.ads

1package Book.Additional_Operations is

2

3   function Get_Extended_Title return String;

4

5   function Get_Extended_Author return String;

6

7end Book.Additional_Operations;

Это тела обоих пакетов:

book.adb

1package body Book is

2

3   Author : constant String :=

4     "Author not visible for my children";

5

6   function Get_Title return String is

7   begin

8      return Title;

9   end Get_Title;

10

11   function Get_Author return String is

12   begin

13      return Author;

14   end Get_Author;

15

16end Book;

book-additional_operations.adb

1package body Book.Additional_Operations is

2

3   function Get_Extended_Title return String is

4   begin

5      return "Book Title: " & Title;

6   end Get_Extended_Title;

7

8   function Get_Extended_Author return String is

9   begin

10      --  "Author" string declared in the body

11      --  of the Book package is not visible

12      --  here. Therefore, we cannot write:

13      --

14      --  return "Book Author: " & Author;

15

16      return "Book Author: Unknown";

17   end Get_Extended_Author;

18

19end Book.Additional_Operations;

В реализации Get_Extended_Title мы используем константу Title из родительского пакета Book. Однако, как указано в комментариях к функции Get_Extended_Author, строка Author, которую мы объявили в теле пакета Book, не отображается в пакете Book.Additional_Operations. Следовательно, мы не можем использовать его для реализации функции Get_Extended_Author.

Однако мы можем использовать функцию Get_Author из Book в реализации функции Get_Extended_Author для получения этой строки. Точно так же мы можем использовать эту стратегию для реализации функции Get_Extended_Title. Это адаптированный код:

book-additional_operations.adb

1package body Book.Additional_Operations is

2

3   function Get_Extended_Title return String is

4   begin

5      return "Book Title: " & Get_Title;

6   end Get_Extended_Title;

7

8   function Get_Extended_Author return String is

9   begin

10      return "Book Author: " & Get_Author;

11   end Get_Extended_Author;

12

13end Book.Additional_Operations;

Вот простое тестовое приложение для указанных выше пакетов:

main.adb

1with Ada.Text_IO;                use Ada.Text_IO;

2with Book.Additional_Operations; use Book.Additional_Operations;

3

4procedure Main is

5begin

6   Put_Line (Get_Extended_Title);

7   Put_Line (Get_Extended_Author);

8end Main;

Runtime output

Book Title: Visible for my children

Book Author: Author not visible for my children

Объявляя элементы в теле пакета, мы можем реализовать инкапсуляцию в языке Ада. Эти элементы будут видимы только в теле пакета, но нигде больше. Но это не единственный способ добиться инкапсуляции в Аде: мы обсудим другие подходы в главе Изоляция.

Переименование

Ранее мы упоминали, что подпрограммы можно переименовывать. Мы также можем переименовывать пакеты. Опять же, для этого мы используем ключевое слово renames. В следующем примере пакет Ada.Text_IO переименовывается как TIO:

main.adb

1with Ada.Text_IO;

2

3procedure Main is

4   package TIO renames Ada.Text_IO;

5begin

6   TIO.Put_Line ("Hello");

7end Main;

Runtime output

Hello

Мы можем использовать переименование, чтобы улучшить читаемость нашего кода, используя более короткие имена пакетов. В приведенном выше примере мы пишем TIO.Put_Line вместо более длинного имени (Ada.Text_IO.Put_Line). Этот подход особенно полезен, когда мы не используем спецификатор использования use, но хотим, чтобы код не становился слишком многословным.

Обратите внимание, что мы также можем переименовывать подпрограммы и объекты внутри пакетов. Например, мы могли бы просто переименовать процедуру Put_Line в приведенном выше примере исходного кода:

main.adb

1with Ada.Text_IO;

2

3procedure Main is

4   procedure Say (Something : String)

5     renames Ada.Text_IO.Put_Line;

6begin

7   Say ("Hello");

8end Main;

Runtime output

Hello

Footnotes

Сильно типизированный язык

Ада - это строго типизированный язык. Удивительно, как она современна в этом: сильная статическая типизация становится все более популярной в дизайне языков программирования, если судить по таким факторам, как развитие функционального программирования со статической типизацией, прилагаемые усилия в области типизации со стороны исследовательского сообщества и появление множества практических языков с сильными системами типов.

Что такое тип?

В статически типизированных языках тип в основном (но не только) является конструкцией времени компиляции. Это конструкция, обеспечивающая инварианты поведения программы. Инварианты - это неизменяемые свойства, которые сохраняются для всех переменных данного типа. Их применение гарантирует, например, что значения переменных данного типа никогда не будут иметь недопустимых значений.

Тип используется для описания объектов, которыми управляет программа (объект это переменная или константа). Цель состоит в том, чтобы классифицировать объекты по тому, что можно с ними сделать (т.е. по разрешенным операциям), и, таким образом, судить о правильности значений объектов.

Целочисленные типы - Integers

Приятной возможностью языка Ада является то, что вы можете определить свои собственные целочисленные типы, основываясь на требованиях вашей программы (т.е. на диапазоне значений, который имеет смысл). Фактически механизм определения типов, который предоставляет Ада, лежит в основе предопределённых целочисленных типов. Таким образом, в языке нет «магических» встроенных типов, как в большинстве других языков, и это, пожалуй, очень элегантно.

integer_type_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Integer_Type_Example is

4   --  Declare a signed integer type,

5   --  and give the bounds

6   type My_Int is range -1 .. 20;

7   --                         ^ High bound

8   --                   ^ Low bound

9

10   --  Like variables, type declarations can

11   --  only appear in declarative regions.

12begin

13   for I in My_Int loop

14      Put_Line (My_Int'Image (I));

15      --              ^ 'Image attribute

16      --                converts a value

17      --                to a String.

18   end loop;

19end Integer_Type_Example;

Runtime output

-1

0

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

Этот пример иллюстрирует объявление целочисленного типа со знаком, и несколько моментов, связанных с его использованием.

Каждое объявление типа в Аде начинается с ключевого слова type (кроме задачных типов). После ключевого слова мы можем видеть определение нижней и верхней границ типа в виде диапазона, который очень похож на диапазоны используемые в циклах for. Любое целое число этого диапазона является допустимым значением для данного типа.

Целочисленные типы Ада

В Аде целочисленный тип задается не в терминах его машинного представления, а скорее его диапазоном. Затем компилятор сам выберет наиболее подходящее представление.

Еще один момент, который следует отметить в приведенном выше примере, - это выражение My_Int'Image (I). Обозначение вида Name'Attribute (необязательные параметры) используется для того, что в Аде называется атрибутом. Атрибут - это встроенная операция над типом, значением или какой-либо другой программной сущностью. Доступ к нему осуществляется с помощью символа ' (апостроф в ASCII).

Ада имеет несколько "встроенных" типов; Integer - один из них. Вот как тип целых чисел Integer может быть определен для типичного процессора:

type Integer is

range -(2 ** 31) .. +(2 ** 31 - 1);

Знак ** обозначает возведение в степень, в итоге, первое допустимое значение для типа Integer равно -2^31, а последнее допустимое значение равно 2^31 - 1.

Ада не регламентирует диапазон встроенного типа Integer. Реализация для 16-битного целевого процессора, вероятно, выберет диапазон от - 2^15 до 2^15 - 1.

Семантика операций

В отличие от некоторых других языков, Ада требует, чтобы операции с целыми числами контролировали переполнение.

main.adb

1procedure Main is

2   A : Integer := Integer'Last;

3   B : Integer;

4begin

5   B := A + 5;

6   --  This operation will overflow, eg. it

7   --  will raise an exception at run time.

8end Main;

Build output

main.adb:2:04: warning: "A" is not modified, could be declared constant [-gnatwk]

main.adb:3:04: warning: variable "B" is assigned but never read [-gnatwm]

main.adb:5:04: warning: possibly useless assignment to "B", value might not be referenced [-gnatwm]

main.adb:5:11: warning: value not in range of type "Standard.Integer" [enabled by default]

main.adb:5:11: warning: "Constraint_Error" will be raised at run time [enabled by default]

Runtime output

raised CONSTRAINT_ERROR : main.adb:5 overflow check failed

Существует два типа проверок переполнения:

- Переполнение на уровне процессора, когда результат операции превышает максимальное значение (или меньше минимального значения), которое может поместиться в машинном представлении объекта данного типа, и

- Переполнение на уровне типа, если результат операции выходит за пределы диапазона, определенного для типа.

В основном по соображениям эффективности, переполнение уровня типа будет проверяться лишь в определенные моменты, такие как присваивание значения, тогда как, переполнение низкого уровня всегда приводит к возбуждению исключения:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4   type My_Int is range 1 .. 20;

5   A : My_Int := 12;

6   B : My_Int := 15;

7   M : My_Int := (A + B) / 2;

8   --  No overflow here, overflow checks

9   --  are done at specific boundaries.

10begin

11   for I in 1 .. M loop

12      Put_Line ("Hello, World!");

13   end loop;

14   --  Loop body executed 13 times

15end Main;

Build output

main.adb:5:04: warning: "A" is not modified, could be declared constant [-gnatwk]

main.adb:6:04: warning: "B" is not modified, could be declared constant [-gnatwk]

main.adb:7:04: warning: "M" is not modified, could be declared constant [-gnatwk]

Runtime output

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Hello, World!

Переполнение уровня типа будет проверяться только в определенных точках выполнения. Результат, как мы видим выше, состоит в том, что у вас может быть операция в промежуточном вычислении, которая переполняется, но никаких исключений не будет, пока конечный результат не вызовет переполняения.

Беззнаковые типы

Ада также поддерживает целочисленные типы без знака. На языке Ада они называются модульными типами. Причина такого обозначения связана с их поведением в случае переполнения: они просто "заварачиваются", как если бы была применена операция по модулю.

Для модульных типов машинного размера, например модуля 2 32, это имитирует наиболее распространенное поведение реализации беззнаковых типов. Однако преимущество Ада в том, что модуль может быть произвольным:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4   type Mod_Int is mod 2 ** 5;

5   --              ^ Range is 0 .. 31

6

7   A : constant Mod_Int := 20;

8   B : constant Mod_Int := 15;

9

10   M : constant Mod_Int := A + B;

11   --  No overflow here,

12   --  M = (20 + 15) mod 32 = 3

13begin

14   for I in 1 .. M loop

15      Put_Line ("Hello, World!");

16   end loop;

17end Main;

Runtime output

Hello, World!

Hello, World!

Hello, World!

В отличие от C/C++, такое поведение гарантировано спецификацией языка Ада и на него можно положиться при создании переносимого кода. Кроме того, для реализации определенных алгоритмов и структур данных, таких как кольцевые буферы#1, очень удобно иметь возможность использовать эффект "заворачивания" на произвольных границах, ведь модуль не обязательно должен быть степенью 2.

Перечисления

Перечислимые типы - еще одна особенность системы типов в Аде. В отличие от перечислений C, они не являются целыми числами, и каждый новый перечислимый тип несовместим с другими перечислимыми типами. Перечислимые типы являются частью большего семейства дискретных типов, что делает их пригодными для использования в определенных ситуациях, которые мы опишем позже, но один контекст, с которым мы уже встречались, - это оператор case.

enumeration_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Enumeration_Example is

4   type Days is (Monday, Tuesday, Wednesday,

5                 Thursday, Friday,

6                 Saturday, Sunday);

7   --  An enumeration type

8begin

9   for I in Days loop

10      case I is

11         when Saturday .. Sunday =>

12            Put_Line ("Week end!");

13

14         when Monday .. Friday =>

15            Put_Line ("Hello on "

16                      & Days'Image (I));

17            --  'Image attribute, works on

18            --  enums too

19      end case;

20   end loop;

21end Enumeration_Example;

Runtime output

Hello on MONDAY

Hello on TUESDAY

Hello on WEDNESDAY

Hello on THURSDAY

Hello on FRIDAY

Week end!

Week end!

Типы перечисления достаточно мощные, поэтому, в отличие от большинства языков, они используются для определения стандартного логического типа:

type Boolean is (False, True);

Как упоминалось ранее, каждый "встроенный" тип в Аде определяется с помощью средств, обычно доступных пользователю.

Типы с плавающей запятой

Основные свойства

Как и большинство языков, Ада поддерживает типы с плавающей запятой. Наиболее часто используемый тип с плавающей запятой - Float:

floating_point_demo.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Floating_Point_Demo is

4   A : constant Float := 2.5;

5begin

6   Put_Line ("The value of A is "

7             & Float'Image (A));

8end Floating_Point_Demo;

Runtime output

The value of A is  2.50000E+00

Приложение отобразит 2.5 как значение A.

Язык Ада не регламентирует точность (количество десятичных цифр в мантиссе) для Float; на типичной 32-разрядной машине точность будет равна 6.

Доступны все общепринятые операции, которые можно было бы ожидать для типов с плавающей запятой, включая получение абсолютного значения и возведение в степень. Например:

floating_point_operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Floating_Point_Operations is

4   A : Float := 2.5;

5begin

6   A := abs (A - 4.5);

7   Put_Line ("The value of A is "

8             & Float'Image (A));

9

10   A := A ** 2 + 1.0;

11   Put_Line ("The value of A is "

12             & Float'Image (A));

13end Floating_Point_Operations;

Runtime output

The value of A is  2.00000E+00

The value of A is  5.00000E+00

Значение A равно 2.0 после первой операции и 5.0 после второй операции.

В дополнение к Float, реализация Ада может предлагать типы данных с более высокой точностью, такие как Long_Float и Long_Long_Float. Как и для Float, стандарт не указывает требуемую точность этих типов: он только гарантирует, что тип Long_Float, например, имеет точность не хуже Float. Чтобы гарантировать необходимую точность, можно определить свой пользовательский тип с плавающей запятой, как будет показано в следующем разделе.

Точность типов с плавающей запятой

Ада позволяет пользователю определить тип с плавающей запятой с заданной точностью, выраженной в десятичных знаках. Все операции этого типа будут иметь, по крайней мере, заданную точность. Синтаксис простого объявления типа с плавающей запятой:

type T is digits <number_of_decimal_digits>;

Компилятор выберет представление с плавающей запятой, поддерживающее требуемую точность. Например:

custom_floating_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Custom_Floating_Types is

4   type T3  is digits 3;

5   type T15 is digits 15;

6   type T18 is digits 18;

7begin

8   Put_Line ("T3  requires "

9             & Integer'Image (T3'Size)

10             & " bits");

11   Put_Line ("T15 requires "

12             & Integer'Image (T15'Size)

13             & " bits");

14   Put_Line ("T18 requires "

15             & Integer'Image (T18'Size)

16             & " bits");

17end Custom_Floating_Types;

Runtime output

T3  requires  32 bits

T15 requires  64 bits

T18 requires  128 bits

В этом примере атрибут «'Size» используется для получения количества бит, используемых для указанного типа данных. Как видно из этого примера, компилятор выделяет 32 бита для T3, 64 бита для T15 и 128 битов для T18. Сюда входят как мантисса, так и экспонента.

Количество цифр, указанное в типе данных, также используется в формате при отображении переменных с плавающей точкой. Например:

display_custom_floating_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Display_Custom_Floating_Types is

4   type T3  is digits 3;

5   type T18 is digits 18;

6

7   C1 : constant := 1.0e-4;

8

9   A : constant T3  := 1.0 + C1;

10   B : constant T18 := 1.0 + C1;

11begin

12   Put_Line ("The value of A is "

13             & T3'Image (A));

14   Put_Line ("The value of B is "

15             & T18'Image (B));

16end Display_Custom_Floating_Types;

Runtime output

The value of A is  1.00E+00

The value of B is  1.00010000000000000E+00

Как и ожидалось, приложение будет отображать переменные в соответствии с заданной точностью (1.00E + 00 и 1.00010000000000000E + 00).

Диапазон значений для типов с плавающей запятой

В дополнение к точности для типа с плавающей запятой можно также задать диапазон. Синтаксис аналогичен записи для целочисленных типов данных — с использованием ключевого слова range. В этом простом примере создается новый тип с плавающей запятой на основе типа Float с диапазоном от -1.0 до 1.0:

floating_point_range.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Floating_Point_Range is

4   type T_Norm  is new Float range -1.0 .. 1.0;

5   A  : T_Norm;

6begin

7   A := 1.0;

8   Put_Line ("The value of A is "

9             & T_Norm'Image (A));

10end Floating_Point_Range;

Runtime output

The value of A is  1.00000E+00

Приложение отвечает за обеспечение того, чтобы переменные этого типа находились в пределах этого диапазона; в противном случае возникает исключение. В следующем примере Constraint_Error исключения возникает при присваивании значения 2.0 переменной A:

floating_point_range_exception.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Floating_Point_Range_Exception is

4   type T_Norm  is new Float range -1.0 .. 1.0;

5   A  : T_Norm;

6begin

7   A := 2.0;

8   Put_Line ("The value of A is "

9             & T_Norm'Image (A));

10end Floating_Point_Range_Exception;

Build output

floating_point_range_exception.adb:7:09: warning: value not in range of type "T_Norm" defined at line 4 [enabled by default]

floating_point_range_exception.adb:7:09: warning: "Constraint_Error" will be raised at run time [enabled by default]

Runtime output

raised CONSTRAINT_ERROR : floating_point_range_exception.adb:7 range check failed

Диапазоны также могут быть заданы для пользовательских типов с плавающей запятой. Например:

custom_range_types.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Ada.Numerics; use Ada.Numerics;

3

4procedure Custom_Range_Types is

5   type T6_Inv_Trig  is

6     digits 6 range -Pi / 2.0 .. Pi / 2.0;

7begin

8   null;

9end Custom_Range_Types;

Build output

custom_range_types.adb:1:09: warning: no entities of "Ada.Text_IO" are referenced [-gnatwu]

custom_range_types.adb:1:20: warning: use clause for package "Text_IO" has no effect [-gnatwu]

custom_range_types.adb:5:09: warning: type "T6_Inv_Trig" is not referenced [-gnatwu]

В этом примере мы определяем тип под названием T6_Inv_Trig, который имеет диапазон от −𝜋/2 до 𝜋/2 с минимальной точностью 6 цифр. (Pi определяется в предопределенном пакете Ada.Numerics.)

Строгая типизация

Как отмечалось ранее, язык Ада строго типизирован. В результате разные типы одного семейства несовместимы друг с другом; значение одного типа не может быть присвоено переменной другого типа. Например:

illegal_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Illegal_Example is

4   --  Declare two different floating point types

5   type Meters is new Float;

6   type Miles is new Float;

7

8   Dist_Imperial : Miles;

9

10   --  Declare a constant

11   Dist_Metric : constant Meters := 1000.0;

12begin

13   --  Not correct: types mismatch

14   Dist_Imperial := Dist_Metric * 621.371e-6;

15   Put_Line (Miles'Image (Dist_Imperial));

16end Illegal_Example;

Build output

illegal_example.adb:14:33: error: expected type "Miles" defined at line 6

illegal_example.adb:14:33: error: found type "Meters" defined at line 5

gprbuild: *** compilation phase failed

Следствием этих правил является то, что в общем случае выражение «смешанного режима» типа 2 * 3.0 инициирует ошибку компиляции. В языке, таком как C или Python, такие выражения допустимы благодаря неявным преобразованиям типов. В Ада такие преобразования должны быть явными:

conv.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Conv is

3   type Meters is new Float;

4   type Miles is new Float;

5   Dist_Imperial : Miles;

6   Dist_Metric : constant Meters := 1000.0;

7begin

8   Dist_Imperial := Miles (Dist_Metric) * 621.371e-6;

9   --               ^ Type conversion,

10   --                 from Meters to Miles

11   --  Now the code is correct

12

13   Put_Line (Miles'Image (Dist_Imperial));

14end Conv;

Runtime output

6.21371E-01

Конечно, мы, вероятно, не хотим писать код преобразования каждый раз, когда мы преобразуем метры в мили. Идиоматическим решением в этом случае считается введение функции преобразования вместе с типами.

conv.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Conv is

4   type Meters is new Float;

5   type Miles is new Float;

6

7   --  Function declaration, like procedure

8   --  but returns a value.

9   function To_Miles (M : Meters) return Miles is

10   --                             ^ Return type

11   begin

12      return Miles (M) * 621.371e-6;

13   end To_Miles;

14

15   Dist_Imperial : Miles;

16   Dist_Metric   : constant Meters := 1000.0;

17begin

18   Dist_Imperial := To_Miles (Dist_Metric);

19   Put_Line (Miles'Image (Dist_Imperial));

20end Conv;

Runtime output

6.21371E-01

Если вы пишете код, где много вычислений, то необходимость явных преобразований может показаться обременительным. Однако такой подход дает определенные преимущества. Ведь вы можете полагаться на отсутствие неявных преобразований, которые, в свою очередь, могут привести к тяжело обнаружимым ошибкам.

На других языках

В C, например, правила для неявных преобразований не всегда могут быть полностью очевидными. Однако в Аде код всегда будет делать именно то, что, явно определено программистом. Например:

int a = 3, b = 2;

float f = a / b;

Этот код будет компилироваться нормально, но результатом f будет 1.0 вместо 1.5, потому что компилятор сгенерирует целочисленное деление (три, разделенное на два), что приведет к единице. Разработчик программного обеспечения должен знать о проблемах преобразования данных и использовать соответствующее приведение типов:

int a = 3, b = 2;

float f = (float)a / b;

В исправленном примере компилятор преобразует обе переменные в соответствующее представление с плавающей запятой перед выполнением деления. Что даст ожидаемый результат.

Этот пример очень прост, и опытные разработчики C, вероятно, заметят и исправят его, прежде чем это создаст большие проблемы. Однако в более сложных приложениях, где объявление типа не всегда видно - например, при ссылке на элементы структуры struct, - эта ситуация может не всегда быть очевидной и быстро привести к дефектам программного обеспечения, которые обнаружить может быть сложнее.

Компилятор Ада, напротив, всегда будет отклонять код, который смешивает переменные с плавающей запятой и целочисленные переменные без явного преобразования. Следующий Ада код, основанный на ошибочном примере в C, не будет компилироваться:

main.adb

1procedure Main is

2   A : Integer := 3;

3   B : Integer := 2;

4   F : Float;

5begin

6   F := A / B;

7end Main;

Build output

main.adb:6:04: warning: possibly useless assignment to "F", value might not be referenced [-gnatwm]

main.adb:6:11: error: expected type "Standard.Float"

main.adb:6:11: error: found type "Standard.Integer"

gprbuild: *** compilation phase failed

Строка с ошибкой должна быть изменена на F := Float (A) / Float (B);.

- Вы можете использовать строгую типизацию Ада, чтобы обеспечить соблюдение инвариантов в вашем коде, как в приведенном выше примере: поскольку мили и метры - это два разных типа, вы не можете случайно использовать значения одного типа вместо другого.

Производные типы

В Ада можно создавать новые типы на основе существующих. Это очень полезно: вы получаете тип, который имеет те же свойства, что и некоторый существующий тип, но ведет себя как отдельный тип в соответствии с правилами сильной типизации.

main.adb

1procedure Main is

2   --  ID card number type,

3   --  incompatible with Integer.

4   type Social_Security_Number is new Integer

5     range 0 .. 999_99_9999;

6   --      ^ Since a SSN has 9 digits

7   --        max., and cannot be

8   --        negative, we enforce

9   --        a validity constraint.

10

11   SSN : Social_Security_Number :=

12     555_55_5555;

13   --   ^ You can put underscores as

14   --     formatting in any number.

15

16   I   : Integer;

17

18   --  The value -1 below will cause a

19   --  runtime error and a compile time

20   --  warning with GNAT.

21   Invalid : Social_Security_Number := -1;

22begin

23   --  Illegal, they have different types:

24   I := SSN;

25

26   --  Likewise illegal:

27   SSN := I;

28

29   --  OK with explicit conversion:

30   I := Integer (SSN);

31

32   --  Likewise OK:

33   SSN := Social_Security_Number (I);

34end Main;

Build output

main.adb:21:40: warning: value not in range of type "Social_Security_Number" defined at line 4 [enabled by default]

main.adb:21:40: warning: "Constraint_Error" will be raised at run time [enabled by default]

main.adb:24:09: error: expected type "Standard.Integer"

main.adb:24:09: error: found type "Social_Security_Number" defined at line 4

main.adb:27:11: error: expected type "Social_Security_Number" defined at line 4

main.adb:27:11: error: found type "Standard.Integer"

main.adb:33:04: warning: possibly useless assignment to "SSN", value might not be referenced [-gnatwm]

gprbuild: *** compilation phase failed

Тип Social_Security, как говорят, является производным типом; его родительский тип - Integer.

Как показано в этом примере, вы можете уточнить допустимый диапазон значений при определении производного скалярного типа (такого как целое число, число с плавающей запятой и перечисление).

Синтаксис перечислений использует синтаксис range <диапазон>:

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   type Days is (Monday, Tuesday, Wednesday,

5                 Thursday, Friday,

6                 Saturday, Sunday);

7

8   type Weekend_Days is new

9     Days range Saturday .. Sunday;

10   --  New type, where only Saturday and Sunday

11   --  are valid literals.

12begin

13   null;

14end Greet;

Build output

greet.adb:1:09: warning: no entities of "Ada.Text_IO" are referenced [-gnatwu]

greet.adb:1:19: warning: use clause for package "Text_IO" has no effect [-gnatwu]

greet.adb:4:18: warning: literal "Monday" is not referenced [-gnatwu]

greet.adb:4:26: warning: literal "Tuesday" is not referenced [-gnatwu]

greet.adb:4:35: warning: literal "Wednesday" is not referenced [-gnatwu]

greet.adb:5:18: warning: literal "Thursday" is not referenced [-gnatwu]

greet.adb:5:28: warning: literal "Friday" is not referenced [-gnatwu]

greet.adb:8:09: warning: type "Weekend_Days" is not referenced [-gnatwu]

Подтипы

Вышеизложенное может привести нас к идее, что типы в Аде могут быть использованы для наложения ограничений на диапазон допустимый значений. Но иногда бывает нужно ограничить значения оставаясь в пределах одного типа. Здесь приходят на помощь подтипы. Подтип не вводит новый тип.

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   type Days is (Monday, Tuesday, Wednesday,

5                 Thursday, Friday,

6                 Saturday, Sunday);

7

8   --  Declaration of a subtype

9   subtype Weekend_Days is

10     Days range Saturday .. Sunday;

11   --     ^ Constraint of the subtype

12

13   M : Days := Sunday;

14

15   S : Weekend_Days := M;

16   --  No error here, Days and Weekend_Days

17   --  are of the same type.

18begin

19   for I in Days loop

20      case I is

21         --  Just like a type, a subtype can

22         --  be used as a range

23         when Weekend_Days =>

24            Put_Line ("Week end!");

25         when others =>

26            Put_Line ("Hello on "

27                      & Days'Image (I));

28      end case;

29   end loop;

30end Greet;

Build output

greet.adb:13:04: warning: "M" is not modified, could be declared constant [-gnatwk]

greet.adb:15:04: warning: variable "S" is not referenced [-gnatwu]

Runtime output

Hello on MONDAY

Hello on TUESDAY

Hello on WEDNESDAY

Hello on THURSDAY

Hello on FRIDAY

Week end!

Week end!

Несколько подтипов предопределены в стандартном пакете Ада и автоматически доступны вам:

subtype Natural  is Integer range 0 .. Integer'Last;

subtype Positive is Integer range 1 .. Integer'Last;

Хотя подтипы одного типа статически совместимы друг с другом, ограничения проверяются во время выполнения: если вы нарушите ограничение подтипа, будет возбуждено исключение.

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   type Days is (Monday, Tuesday, Wednesday,

5                 Thursday, Friday,

6                 Saturday, Sunday);

7

8   subtype Weekend_Days is

9     Days range Saturday .. Sunday;

10

11   Day     : Days := Saturday;

12   Weekend : Weekend_Days;

13begin

14   Weekend := Day;

15   --         ^ Correct: Same type, subtype

16   --           constraints are respected

17   Weekend := Monday;

18   --         ^ Wrong value for the subtype

19   --           Compiles, but exception at runtime

20end Greet;

Build output

greet.adb:1:09: warning: no entities of "Ada.Text_IO" are referenced [-gnatwu]

greet.adb:1:19: warning: use clause for package "Text_IO" has no effect [-gnatwu]

greet.adb:4:26: warning: literal "Tuesday" is not referenced [-gnatwu]

greet.adb:4:35: warning: literal "Wednesday" is not referenced [-gnatwu]

greet.adb:5:18: warning: literal "Thursday" is not referenced [-gnatwu]

greet.adb:5:28: warning: literal "Friday" is not referenced [-gnatwu]

greet.adb:11:04: warning: "Day" is not modified, could be declared constant [-gnatwk]

greet.adb:12:04: warning: variable "Weekend" is assigned but never read [-gnatwm]

greet.adb:14:04: warning: useless assignment to "Weekend", value overwritten at line 17 [-gnatwm]

greet.adb:17:04: warning: possibly useless assignment to "Weekend", value might not be referenced [-gnatwm]

greet.adb:17:15: warning: value not in range of type "Weekend_Days" defined at line 8 [enabled by default]

greet.adb:17:15: warning: "Constraint_Error" will be raised at run time [enabled by default]

Runtime output

raised CONSTRAINT_ERROR : greet.adb:17 range check failed

Подтипы в качестве псевдонимов типов

Ранее мы видели, что мы можем создавать новые типы, объявляя type Miles is new Float. Но нам также может потребоваться переименовать тип, просто чтобы ввести альтернативное имя-псевдоним для существующего типа. Следует отметить, что псевдонимы типов иногда называются синонимами типов.

В Аде это делается с помощью подтипов без новых ограничений. Однако в этом случае мы не получаем всех преимуществ строгой типизации Ады. Перепишем пример, используя псевдонимы типов:

undetected_imperial_metric_error.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Undetected_Imperial_Metric_Error is

4   --  Declare two type aliases

5   subtype Meters is Float;

6   subtype Miles is Float;

7

8   Dist_Imperial : Miles;

9

10   --  Declare a constant

11   Dist_Metric : constant Meters := 100.0;

12begin

13   --  No conversion to Miles type required:

14   Dist_Imperial := (Dist_Metric * 1609.0) / 1000.0;

15

16   --  Not correct, but undetected:

17   Dist_Imperial := Dist_Metric;

18

19   Put_Line (Miles'Image (Dist_Imperial));

20end Undetected_Imperial_Metric_Error;

Build output

undetected_imperial_metric_error.adb:14:04: warning: useless assignment to "Dist_Imperial", value overwritten at line 17 [-gnatwm]

Runtime output

1.00000E+02

В приведенном выше примере тот факт, что и метры (Meters), и мили (Miles) являются подтипами Float, позволяет нам смешивать переменные обоих типов без преобразования типов. Это, однако, может привести к всевозможным ошибкам в программировании, которых мы стремимся избежать, как можно видеть в необнаруженной ошибке, выделенной в приведенном выше коде. В этом примере ошибка в присвоении значения в метрах переменной, предназначенной для хранения значений в милях, остается необнаруженной, поскольку и метры (Meters), и мили (Miles) являются подтипами Float. Поэтому, для случаев, подобных приведенному выше, рекомендуется использовать строгую типизацию, опеделив тип X производным от типа Y (type X is new Y).

Однако существует много ситуаций, где псевдонимы типов полезны. Например, в приложении, которое использует типы с плавающей запятой в нескольких контекстах, мы могли бы использовать псевдонимы типов, чтобы уточнить преднозначение или избежать длинных имен переменных. Например, вместо того, чтобы писать:

Paid_Amount, Due_Amount : Float;

Мы можем написать:

subtype Amount is Float;

Paid, Due : Amount;

На других языках

Например, в C для создания псевдонима типа можно использовать объявление typedef. Например:

typedef float meters;

Это соответствует определению подтипа без ограничений, которое мы видели выше. Другие языки программирования вводят эту концепцию аналогичными способами. Например:

- C++: using meters = float;

- Swift: typealias Meters = Double

- Kotlin: typealias Meters = Double

- Haskell: type Meters = Float

Однако следует отметить, что подтипы в Аде соответствуют псевдонимам типов, если и только если они не вводят новых ограничений. Таким образом, если добавить новое ограничение к описанию подтипа, у нас больше не будет псевдонима типа. Например, следующее объявление не может считаться синонимом типа Float:

subtype Meters is Float range 0.0 .. 1_000_000.0;

Рассмотрим другой пример:

subtype Degree_Celsius is Float;

subtype Liquid_Water_Temperature is

Degree_Celsius range 0.0 .. 100.0;

subtype Running_Water_Temperature is

Liquid_Water_Temperature;

В этом примере Liquid_Water_Temperature не является псевдонимом Degree_Celsius, поскольку добавляет новое ограничение, которое не было частью объявления Degree_Celsius. Однако здесь есть два псевдонима типа:

- Degree_Celsius является псевдонимом Float;

- Running_Water_Temperature является псевдонимом Liquid_Water_Temperature, даже если сам Liquid_Water_Temperature имеет ограниченный диапазон.

Footnotes

#1

https://ru.wikipedia.org/wiki/Кольцевой_буфер

Записи

Пока что все типы, с которыми мы столкнулись, имеют значения, которые нельзя разложить: каждый экземпляр представляет собой неделимый элемент данных. Теперь мы обратим наше внимание на наш первый составной тип: записи.

Записи позволяют составлять значения из значений других типов. Каждому из таких значений будет присвоено имя. Пара, состоящая из имени и значения определенного типа, называется полем или компонентой.

Объявление типа записи

Вот пример простого объявления записи:

type Date is record

--  The following declarations are

--  components of the record

Day   : Integer range 1 .. 31;

Month : Months;

--  You can add custom constraints

--  on fields

Year  : Integer range 1 .. 3000;

end record;

Поля во многом похожи на объявления переменных, за исключением того, что они находятся внутри определения записи. Как и при объявлениях переменных, можно указать дополнительные ограничения при предоставлении подтипа поля.

type Date is record

Day   : Integer range 1 .. 31;

Month : Months := January;

--  This component has a default value

Year  : Integer range 1 .. 3000 := 2012;

--                                 ^ Default value

end record;

Компоненты записи могут иметь значения по умолчанию. Когда объявлена переменная с типом записи, для поля с инициализацией получат заданные значения автоматически. Значение может быть задано любым выражением соответствующего типа и может вычислятся во время исполнения.

Агрегаты

Ada_Birthday    : Date := (10, December, 1815);

Leap_Day_2020   : Date := (Day   => 29,

Month => February,

Year  => 2020);

--                         ^ By name

Записи имеют удобную форму для записи значений, показанную выше. Эта нотация называется агрегированной, а сама конструкция - агрегатом. Ее можно использовать в различных контекстах, которые мы увидим на протяжении всего курса, и одним из применений является инициализация записей.

Агрегат - это список значений, разделенных запятыми и заключенных в круглые скобки. Он разрешен в любом контексте, где ожидается значение записи.

Значения для компонент можно указать позиционно, как в примере Ada_Birthday, или по имени, как в Leap_Day_2020. Разрешено сочетание позиционных и именованных значений, но вы не можете использовать позиционную форму после появления именованной.

Извлечение компонент

Для доступа к компонентам экземпляра записи используется операция, называемая извлечением компоненты. Она имеет форму точечной нотации. Например, если мы объявляем переменную Some_Day типа записи Date, упомянутого выше, мы можем получить доступ к компоненте Year, написав Some_Day.Year.

Рассмотрим пример:

record_selection.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Record_Selection is

4

5   type Months is

6     (January, February, March, April,

7      May, June, July, August, September,

8      October, November, December);

9

10   type Date is record

11      Day   : Integer range 1 .. 31;

12      Month : Months;

13      Year  : Integer range 1 .. 3000 := 2032;

14   end record;

15

16   procedure Display_Date (D : Date) is

17   begin

18      Put_Line ("Day:" & Integer'Image (D.Day)

19                & ", Month: "

20                & Months'Image (D.Month)

21                & ", Year:"

22                & Integer'Image (D.Year));

23   end Display_Date;

24

25   Some_Day : Date := (1, January, 2000);

26

27begin

28   Display_Date (Some_Day);

29

30   Put_Line ("Changing year...");

31   Some_Day.Year := 2001;

32

33   Display_Date (Some_Day);

34end Record_Selection;

Runtime output

Day: 1, Month: JANUARY, Year: 2000

Changing year...

Day: 1, Month: JANUARY, Year: 2001

Как вы можете видеть в этом примере, мы можем использовать точечную нотацию в выражении D.Year или Some_Day.Year. как для доступа к информации компонеты, так и для ее изменения в операторе присваивания. Говоря конкретнее, когда мы используем D.Year в вызове Put_Line, мы читаем информацию, хранящуюся в этом компоненте. Когда мы пишем Some_Day.Year := 2001, то перезаписываем информацию, которая была ранее сохранена в компоненте Year в переменной Some_Day.

Переименование

В предыдущих главах мы обсуждали переименование подпрограмм и пакетов. Мы также можем переименовывать компоненты записи. Вместо того, чтобы каждый раз писать извлечение компоненты с использованием точечной записи, мы можем объявить псевдоним, который позволит нам получить доступ к этой компоненте. Это полезно, например, для упрощения реализации подпрограммы.

Мы можем переименовать компоненты записи, используя ключевое слово renames в объявлении переменной. Например:

Some_Day : Date;

Y        : Integer renames Some_Day.Year;

Здесь Y является псевдонимом, так что каждый раз, когда мы используем Y, мы в действительности используем компоненту Year переменной Some_Day.

Давайте рассмотрим полный пример:

dates.ads

1package Dates is

2

3   type Months is

4     (January, February, March, April,

5      May, June, July, August, September,

6      October, November, December);

7

8   type Date is record

9      Day   : Integer range 1 .. 31;

10      Month : Months;

11      Year  : Integer range 1 .. 3000 := 2032;

12   end record;

13

14   procedure Increase_Month (Some_Day : in out Date);

15

16   procedure Display_Month (Some_Day : Date);

17

18end Dates;

dates.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Dates is

4

5   procedure Increase_Month (Some_Day : in out Date) is

6      --  Renaming components from

7      --  the Date record

8      M : Months  renames Some_Day.Month;

9      Y : Integer renames Some_Day.Year;

10

11      --  Renaming function (for Months

12      --  enumeration)

13      function Next (M : Months) return Months

14        renames Months'Succ;

15   begin

16      if M = December then

17         M := January;

18         Y := Y + 1;

19      else

20         M := Next (M);

21      end if;

22   end Increase_Month;

23

24   procedure Display_Month (Some_Day : Date) is

25      --  Renaming components from

26      --  the Date record

27      M : Months  renames Some_Day.Month;

28      Y : Integer renames Some_Day.Year;

29   begin

30      Put_Line ("Month: "

31                & Months'Image (M)

32                & ", Year:"

33                & Integer'Image (Y));

34   end Display_Month;

35

36end Dates;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Dates;       use Dates;

3

4procedure Main is

5   D : Date := (1, January, 2000);

6begin

7   Display_Month (D);

8

9   Put_Line ("Increasing month...");

10   Increase_Month (D);

11

12   Display_Month (D);

13end Main;

Runtime output

Month: JANUARY, Year: 2000

Increasing month...

Month: FEBRUARY, Year: 2000

Мы применяем переименование к двум компонентам записи Date в реализации процедуры Increase_Month. Затем вместо непосредственного использования Some_Day.Month и Some_Day.Year в последующих операциях мы просто используем переименованные версии M и Y.

Обратите внимание, что в приведенном выше примере мы также переименовали Months'Succ - функцию, которая дает нам следующий месяц - в Next.

Footnotes

Массивы

Массивы (или индексируемые типы) предоставляют еще одно фундаментальное семейство составных типов в Аде.

Объявление типа массива

Массивы в Аде используются для определения непрерывных коллекций элементов, к которым можно обращаться по индексу.

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   type My_Int is range 0 .. 1000;

5   type Index is range 1 .. 5;

6

7   type My_Int_Array is

8     array (Index) of My_Int;

9   --                 ^ Type of elements

10   --       ^ Bounds of the array

11   Arr : My_Int_Array := (2, 3, 5, 7, 11);

12   --                    ^ Array literal

13   --                      (aggregate)

14

15   V : My_Int;

16begin

17   for I in Index loop

18      V := Arr (I);

19      --        ^ Take the Ith element

20      Put (My_Int'Image (V));

21   end loop;

22   New_Line;

23end Greet;

Build output

greet.adb:11:04: warning: "Arr" is not modified, could be declared constant [-gnatwk]

Runtime output

2 3 5 7 11

Первое, что следует отметить, - это то, что мы указываем не размер массива, а тип его индекса. Здесь мы объявили целочисленный тип с именем Index в диапазоне от 1 до 5, поэтому каждый экземпляр массива будет иметь 5 элементов, с индексами от 1 до 5.

Хотя в этом примере в качестве индекса использовался целочисленный тип, в Аде любой дискретный тип может служить для индексации массива, включая (перечислимые типы). Скоро мы увидим, что это значит.

Следующий момент, который следует отметить, заключается в том, что доступ к элементу массива по заданному индексу использует тот же синтаксис, что и для вызовов функций: то есть имя массива, за которым следует индекс в скобках.

Таким образом, когда вы видите выражение, такое как A (B), является ли оно вызовом функции или индексом массива, зависит от того, на что ссылается A.

Наконец, обратите внимание, как мы инициализируем массив выражением (2, 3, 5, 7, 11). Это еще один вид агрегата в Аде, который в некотором смысле является литералом для массива, точно так же, как 3 является литералом для целого числа. Обозначение очень мощное, с рядом свойств, которые мы представим позже. Подробный обзор приводится в главе о агрегатах типов.

Пример также иллюстрирует две процедуры из:ada:Ada.Text_IO, которые не связанны с массивами:

- Put - выводит строку без завершающего конца строки.

- New_Line - вывод конца строки

Давайте теперь углубимся в то, что значит иметь возможность использовать любой дискретный тип в качестве индекса массива.

На других языках

Семантически объект массива в Аде - это цельная структура данных, а не просто дескриптор или указатель. В отличие от C и C ++, не существует неявной эквивалентности между массивом и указателем на его начальный элемент.

array_bounds_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Array_Bounds_Example is

4   type My_Int is range 0 .. 1000;

5   type Index is range 11 .. 15;

6   --                  ^ Low bound can be any value

7   type My_Int_Array is array (Index) of My_Int;

8   Tab : constant My_Int_Array := (2, 3, 5, 7, 11);

9begin

10   for I in Index loop

11      Put (My_Int'Image (Tab (I)));

12   end loop;

13   New_Line;

14end Array_Bounds_Example;

Runtime output

2 3 5 7 11

Как следствие границы массива могут иметь произвольные значения. В первом примере мы создали тип массива, первый индекс которого равен 1, но в приведенном выше примере мы объявляем тип массива, первый индекс которого равен 11.

Это прекрасно работает в Аде, а, кроме того, поскольку мы для итерации по массиву указали как диапазон тип индекса, то код использующий массив, не приходится менять.

Это приводит нас к важному принципу написания кода, оперируещего с массивами. Поскольку границы могут меняться, лучше не полагаться на конкретные значения и не указывать их в коде использующем массив. Это означает, что приведенный выше код хорош, потому что он использует тип индекса, но цикл for, приведенный ниже, считается плохой практикой, даже если он работает правильно:

for I in 11 .. 15 loop

Tab (I) := Tab (I) * 2;

end loop;

Поскольку для индексации массива можно использовать любой дискретный тип, разрешены и перечислимые типы.

month_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Month_Example is

4   type Month_Duration is range 1 .. 31;

5   type Month is (Jan, Feb, Mar, Apr,

6                  May, Jun, Jul, Aug,

7                  Sep, Oct, Nov, Dec);

8

9   type My_Int_Array is

10     array (Month) of Month_Duration;

11   --       ^ Can use an enumeration type

12   --         as the index

13

14   Tab : constant My_Int_Array :=

15   --    ^ constant is like a variable but

16   --      cannot be modified

17     (31, 28, 31, 30, 31, 30,

18      31, 31, 30, 31, 30, 31);

19   --  Maps months to number of days

20   --  (ignoring leap years)

21

22   Feb_Days : Month_Duration := Tab (Feb);

23   --  Number of days in February

24begin

25   for M in Month loop

26      Put_Line

27        (Month'Image (M) & " has "

28         & Month_Duration'Image (Tab (M))

29         & " days.");

30   --    ^ Concatenation operator

31   end loop;

32end Month_Example;

Build output

month_example.adb:22:04: warning: variable "Feb_Days" is not referenced [-gnatwu]

Runtime output

JAN has  31 days.

FEB has  28 days.

MAR has  31 days.

APR has  30 days.

MAY has  31 days.

JUN has  30 days.

JUL has  31 days.

AUG has  31 days.

SEP has  30 days.

OCT has  31 days.

NOV has  30 days.

DEC has  31 days.

В приведенном выше примере мы:

- Создание типа массива для отображения месяца в его продолжительность в днях.

- Создание экземпляра этого массива и инициализация его с помощью агрегата указывающего фактическую продолжительностью каждого месяца в днях.

- Итерация по массиву, печать месяцев и количество дней для каждого.

Возможность использования перечислимых значений в качестве индекса очень полезна при создании сопоставлений, как показано выше, и часто используется в Аде.

Доступ по индексу

Мы уже видели синтаксис обращения к элементам массива. Однако следует отметить еще несколько моментов.

Во-первых, как и в целом в Аде, операция индексирования строго типизирована. Если для индексации массива используется значение неправильного типа, будет получена ошибка времени компиляции.

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   type My_Int is range 0 .. 1000;

5

6   type My_Index   is range 1 .. 5;

7   type Your_Index is range 1 .. 5;

8

9   type My_Int_Array is array (My_Index) of My_Int;

10   Tab : My_Int_Array := (2, 3, 5, 7, 11);

11begin

12   for I in Your_Index loop

13      Put (My_Int'Image (Tab (I)));

14   --                         ^ Compile time error

15   end loop;

16   New_Line;

17end Greet;

Build output

greet.adb:13:31: error: expected type "My_Index" defined at line 6

greet.adb:13:31: error: found type "Your_Index" defined at line 7

gprbuild: *** compilation phase failed

Во-вторых, в Аде контролируется выход за границы массива. Это означает, что если вы попытаетесь обратиться к элементу за пределами массива, вы получите ошибку во время выполнения вместо доступа к случайной памяти, как в небезопасных языках.

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   type My_Int is range 0 .. 1000;

5   type Index is range 1 .. 5;

6   type My_Int_Array is array (Index) of My_Int;

7   Tab : My_Int_Array := (2, 3, 5, 7, 11);

8begin

9   for I in Index range 2 .. 6 loop

10      Put (My_Int'Image (Tab (I)));

11      --                      ^ Will raise an

12      --                        exception when

13      --                        I = 6

14   end loop;

15   New_Line;

16end Greet;

Build output

greet.adb:7:04: warning: "Tab" is not modified, could be declared constant [-gnatwk]

greet.adb:9:30: warning: static value out of range of type "Index" defined at line 5 [enabled by default]

greet.adb:9:30: warning: "Constraint_Error" will be raised at run time [enabled by default]

greet.adb:9:30: warning: suspicious loop bound out of range of loop subtype [enabled by default]

greet.adb:9:30: warning: loop executes zero times or raises Constraint_Error [enabled by default]

Runtime output

raised CONSTRAINT_ERROR : greet.adb:9 range check failed

Более простые объявления массива

В предыдущих примерах мы всегда явно создавали тип индекса для массива. Хотя это может быть полезно для типизации и удобства чтения, иногда вам просто нужно указать диапазон значений. Ада позволяет вам делать и так.

simple_array_bounds.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Simple_Array_Bounds is

4   type My_Int is range 0 .. 1000;

5   type My_Int_Array is array (1 .. 5) of My_Int;

6   --                          ^ Subtype of Integer

7   Tab : constant My_Int_Array := (2, 3, 5, 7, 11);

8begin

9   for I in 1 .. 5 loop

10   --       ^ Subtype of Integer

11      Put (My_Int'Image (Tab (I)));

12   end loop;

13   New_Line;

14end Simple_Array_Bounds;

Runtime output

2 3 5 7 11

В этом примере диапазон массива определен с помощью синтаксиса диапазона, который указывает анонимный подтип Integer и использует его в качестве индекса массива.

Это означает, что индекс имеет целочисленный тип Integer. Точно так же, когда вы используете анонимный диапазон в цикле for, как в приведенном выше примере, тип параметра цикла также является Integer, поэтому вы можете использовать I для индексации Tab.

Также вы можете использовать именованный подтип для указания границ массива.

Атрибут диапазона

Ранее мы отметили, что указывать жесткие границы при итерации по массиву - плохая идея, и показали, как использовать тип/подтип индекса массива для итерации в цикле for. Это поднимает вопрос о том, как написать итерацию, когда массив имеет анонимный диапазон для своих границ, поскольку нет имени позволяющего сослаться на диапазон. В Аде эта проблема решается с помощью нескольких атрибутов существующих у массивов:

range_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Range_Example is

4   type My_Int is range 0 .. 1000;

5   type My_Int_Array is array (1 .. 5) of My_Int;

6   Tab : constant My_Int_Array := (2, 3, 5, 7, 11);

7begin

8   for I in Tab'Range loop

9   --          ^ Gets the range of Tab

10      Put (My_Int'Image (Tab (I)));

11   end loop;

12   New_Line;

13end Range_Example;

Runtime output

2 3 5 7 11

Если требуется более точный контроль, можно использовать отдельные атрибуты 'First («Первый») и 'Last («Последний»).

array_attributes_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Array_Attributes_Example is

4   type My_Int is range 0 .. 1000;

5   type My_Int_Array is array (1 .. 5) of My_Int;

6   Tab : My_Int_Array := (2, 3, 5, 7, 11);

7begin

8   for I in Tab'First .. Tab'Last - 1 loop

9   --          ^ Iterate on every index

10   --            except the last

11      Put (My_Int'Image (Tab (I)));

12   end loop;

13   New_Line;

14end Array_Attributes_Example;

Build output

array_attributes_example.adb:6:04: warning: "Tab" is not modified, could be declared constant [-gnatwk]

Runtime output

2 3 5 7

Атрибуты 'Range, 'First и 'Last показанные в этих примерах также можно применять к имени типа массива, а не только к экземплярам массива.

Хотя это не демонстрируется в вышеприведенных примерах, другим полезным атрибутом для экземпляра массива A является A'Length, который возвращает количеством элементов в A.

Законно и иногда полезно иметь «пустой массив», который не содержит элементов. Чтобы получить его, достаточно определить диапазон индексов, верхняя граница которого меньше нижней границы.

Неограниченные массивы

Давайте теперь рассмотрим одину из самых мощных возможностей массивов в языке Ада.

Все типы массивов, который мы определили до сих пор, имеют фиксированный размер: все экземпляры такого типа будут иметь одинаковые границы и, следовательно, одинаковое количество элементов и одинаковый размер.

Но Ада также позволяет объявлять типы массивов, границы которых не являются фиксированными: в этом случае границы необходимо будет указать при создании экземпляров типа.

unconstrained_array_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Unconstrained_Array_Example is

4   type Days is (Monday, Tuesday, Wednesday,

5                 Thursday, Friday,

6                 Saturday, Sunday);

7

8   type Workload_Type is

9     array (Days range <>) of Natural;

10   --  Indefinite array type

11   --       ^ Bounds are of type Days,

12   --         but not known

13

14   Workload : constant

15     Workload_Type (Monday .. Friday) :=

16   --               ^ Specify the bounds

17   --                 when declaring

18      (Friday => 7, others => 8);

19   --               ^ Default value

20   --  ^ Specify element by name of index

21begin

22   for I in Workload'Range loop

23      Put_Line (Integer'Image (Workload (I)));

24   end loop;

25end Unconstrained_Array_Example;

Build output

unconstrained_array_example.adb:4:26: warning: literal "Tuesday" is not referenced [-gnatwu]

unconstrained_array_example.adb:4:35: warning: literal "Wednesday" is not referenced [-gnatwu]

unconstrained_array_example.adb:5:18: warning: literal "Thursday" is not referenced [-gnatwu]

unconstrained_array_example.adb:6:18: warning: literal "Saturday" is not referenced [-gnatwu]

unconstrained_array_example.adb:6:28: warning: literal "Sunday" is not referenced [-gnatwu]

Runtime output

8

8

8

8

7

Тот факт, что границы массива неизвестны, указывается синтаксисом Days range <>. Взяв, для примера дискретный тип Discrete_Type, eсли бы мы указали просто Discrete_Type как индекс массива, то для каждого значения из Discrete_Type существовал бы индекс и соответствующий элемент в каждом экземпляре массива.

Но, если мы определим индекс как Discrete_Type range <>, то, хотя Discrete_Type все еще будет типом индекса, но разные экземпляры массива смогут иметь свои границы.

Тип массива, который определяется с помощью синтаксиса Discrete_Type range <>, называется неограниченным индексируемым типом, и, как показано выше, при создании экземпляра необходимо указать границы.

В приведенном выше примере также показаны другие формы записи агрегата. Вы можете использовать именованное сопоставление, задав значение индекса слева от стрелки. Таким образом, 1 => 2 означает «присвоить значение 2 элементу с индексом 1 в моем массиве». Запись others => 8 означает «присвоить значение 8 каждому элементу, который ранее не был назначен в этом агрегате».

Attention

Так называемый «бокс» (<>) в Аде обычно используется для обозначение места, где отсутствует некий элемент. Как мы увидим еще не раз, такое обозначение можно читать, как «значение, не заданое явно».

На других языках

В то время как неограниченные массивы в Аде могут казаться похожими на массивы переменной длины в C, в действительности они гораздо более мощные, поскольку работают как настоящие значения. Их можно передавать их как параметры при вызове подпрограммам и возвращать как результат функции, и они неявно содержат границы как часть своего значения. Это означает, что нет нужды явно передавать границы или длину массива вместе с массивом, поскольку эти значения доступны через атрибуты 'First, 'Last, 'Range и 'Length, описанные ранее.

Хотя различные экземпляры одного и того же неограниченного типа массива могут иметь разные границы, конкретный экземпляр имеет постоянные границы в течение всего срока его существования. Это позволяет компилятору языка Ада эффективно реализовывать неограниченные массивы; массивы могут храниться в стеке и не требуют выделения в куче, как в других языках, типа Java.

Предопределенный тип String

В нашем введении в типы языка Ада было отмечено, что такие важные встроенные типы, как Boolean или Integer, определяются с помощью тех же средств, что доступны пользователю. Это также верно и для строк: тип String в Аде является простым массивом.

Вот как тип строки определяется в Аде:

type String is array (Positive range <>) of Character;

Единственной дополнительной возможностью, которую Ада добавляет, чтобы сделать строки более простыми в использовании, являются строковые литералы, как мы можем видеть в примере ниже.

Hint

Строковые литералы являются синтаксическим сахаром для агрегатов, так что в следующем примере A и B имеют одинаковое значение.

string_literals.ads

1package String_Literals is

2    --  Those two declarations are equivalent

3    A : String (1 .. 11) := "Hello World";

4    B : String (1 .. 11) :=

5        ('H', 'e', 'l', 'l', 'o', ' ',

6         'W', 'o', 'r', 'l', 'd');

7end String_Literals;

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   Message : String (1 .. 11) := "dlroW olleH";

5   --        ^ Pre-defined array type.

6   --          Component type is Character

7begin

8   for I in reverse Message'Range loop

9      --    ^ Iterate in reverse order

10      Put (Message (I));

11   end loop;

12   New_Line;

13end Greet;

Однако явное указание границ объекта - это немного хлопотно; вам нужно вручную подсчитать количество символов в литерале. К счастью, Ада предлагает более простой способ.

Вы можете опустить границы при создании экземпляра неограниченного типа массива, если вы предоставляете инициализацию, поскольку границы могут быть вычислены по выражению инициализации.

greet.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Greet is

4   Message : constant String := "dlroW olleH";

5   --                 ^ Bounds are automatically

6   --                   computed from

7   --                   initialization value

8begin

9   for I in reverse Message'Range loop

10      Put (Message (I));

11   end loop;

12   New_Line;

13end Greet;

Runtime output

Hello World

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4   type Integer_Array is array (Natural range <>) of Integer;

5

6   My_Array : constant Integer_Array := (1, 2, 3, 4);

7   --                  ^ Bounds are automatically

8   --                    computed from

9   --                    initialization value

10begin

11    null;

12end Main;

Attention

Как вы можете видеть выше, стандартный тип String в Аде - это массив. Таким образом, он сохраняет преимущества и недостатки массивов: значение String выделяется в стеке, доступ к нему осуществляется эффективно, а его границы неизменны.

Если вам нужно что-то вроде :c++:std::string в C++, вы можете использовать Unbounded Strings из стандартной библиотеки Ада. Этот тип больше похож на изменяемый, автоматически управляемый строковый буфер, в который вы можете добавлять содержимое.

Ограничения

Очень важный момент, касающийся массивов: границы должны быть известны при создании экземпляров. Например, незаконно делать следующее.

declare

A : String;

begin

A := "World";

end;

Кроме того, хотя вы, конечно, можете изменять значения элементов в массиве, вы не можете изменять границы массива (и, следовательно, его размер) после его инициализации. Так что это тоже незаконно:

declare

A : String := "Hello";

begin

A := "World";       --  OK: Same size

A := "Hello World"; --  Not OK: Different size

end;

Кроме того, хотя вы можете ожидать предупреждения об ошибке такого рода в очень простых случаях, подобных этому, но компилятор в общем случае не может знать, присваиваете ли вы значение правильной длины, поэтому это нарушение обычно приведет к ошибке во время выполнения.

Обратите внимание

Хотя мы остановимся на этом позже, важно знать, что массивы - не единственные типы, экземпляры которых могут быть неизвестного размера в момент компиляции.

Говорят, что такие объекты имеют неопределенный подтип, что означает, что размер подтипа неизвестен во время компиляции, но динамически вычисляется (во время выполнения).

indefinite_subtypes.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Indefinite_Subtypes is

4    function Get_Number return Integer is

5    begin

6        return Integer'Value (Get_Line);

7    end Get_Number;

8

9   A : String := "Hello";

10   --  Indefinite subtype

11

12   B : String (1 .. 5) := "Hello";

13   --  Definite subtype

14

15   C : String (1 .. Get_Number);

16   --  Indefinite subtype

17   --  (Get_Number's value is computed at

18   --  run-time)

19begin

20   null;

21end Indefinite_Subtypes;

Возврат неограниченных массивов

Тип возвращаемого значения функции может быть любым; функция может возвращать значение, размер которого неизвестен во время компиляции. Точно так же параметры могут быть любого типа.

Например, это функция, которая возвращает неограниченную строку:

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4

5   type Days is (Monday, Tuesday, Wednesday,

6                 Thursday, Friday,

7                 Saturday, Sunday);

8

9   function Get_Day_Name (Day : Days := Monday)

10                          return String is

11   begin

12      return

13        (case Day is

14         when Monday    => "Monday",

15         when Tuesday   => "Tuesday",

16         when Wednesday => "Wednesday",

17         when Thursday  => "Thursday",

18         when Friday    => "Friday",

19         when Saturday  => "Saturday",

20         when Sunday    => "Sunday");

21   end Get_Day_Name;

22

23begin

24   Put_Line ("First day is "

25             & Get_Day_Name (Days'First));

26end Main;

Runtime output

First day is Monday

Примечание. Этот пример приведен только в иллюстративных целях. Существует встроенный механизм, атрибут 'Image для скалярных типов, который возвращает имя (в виде строки – типа String) любого элемента типа перечисления. Например, Days'Image(Monday) есть "MONDAY".)

На других языках

Возврат объектов переменного размера в языках, в которых отсутствует сборщик мусора, довольно сложен с точки зрения реализации, поэтому C и C++ не допускают такого, предпочитая зависеть от явного динамического распределения/освобождения памяти пользователем.

Проблема в том, что явное управление памятью становится небезопасным, как только вы захотите использовать выделенную память повторно. Способность Ада возвращать объекты переменного размера устраняют необходимость динамического распределения для одгого варианта использования и, следовательно, удаляет один потенциальный источник ошибок из ваших программ.

Rust следует модели C/C++, но использует указатели с безопасной семантикой. При этом динамическое распределение все еще используется. Ада может извлечь выгоду в виде повышения производительности, поскольку оставляет возможность использовать любой из этих механизмов.

Объявление массивов (2)

Хотя мы можем иметь типы массивов, размер и границы которых определяются во время выполнения, тип компоненты массива всегда должен быть определенного и ограниченного типа.

Таким образом, если необходимо объявить, например, массив строк, подтип String, используемый в качестве компоненты, должен иметь фиксированный размер.

show_days.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Days is

4   type Days is (Monday, Tuesday, Wednesday,

5                 Thursday, Friday,

6                 Saturday, Sunday);

7

8   subtype Day_Name is String (1 .. 2);

9   --  Subtype of string with known size

10

11   type Days_Name_Type is

12     array (Days) of Day_Name;

13   --       ^ Type of the index

14   --                ^ Type of the element.

15   --                  Must be definite

16

17   Names : constant Days_Name_Type :=

18     ("Mo", "Tu", "We", "Th", "Fr", "Sa", "Su");

19   --  Initial value given by aggregate

20begin

21   for I in Names'Range loop

22      Put_Line (Names (I));

23   end loop;

24end Show_Days;

Build output

show_days.adb:4:18: warning: literal "Monday" is not referenced [-gnatwu]

show_days.adb:4:26: warning: literal "Tuesday" is not referenced [-gnatwu]

show_days.adb:4:35: warning: literal "Wednesday" is not referenced [-gnatwu]

show_days.adb:5:18: warning: literal "Thursday" is not referenced [-gnatwu]

show_days.adb:5:28: warning: literal "Friday" is not referenced [-gnatwu]

show_days.adb:6:18: warning: literal "Saturday" is not referenced [-gnatwu]

show_days.adb:6:28: warning: literal "Sunday" is not referenced [-gnatwu]

Runtime output

Mo

Tu

We

Th

Fr

Sa

Su

Отрезки массива

Последняя особенность массивов Аде, которую мы собираемся рассмотреть, - это отрезки массива. Можно взять и использовать отрезок массива (непрерывную последовательность элементов) в качестве имени или значения.

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4    Buf : String := "Hello ...";

5

6    Full_Name : String := "John Smith";

7begin

8    Buf (7 .. 9) := "Bob";

9    --  Careful! This works because the string

10    --  on the right side is the same length as

11    --  the replaced slice!

12

13    --  Prints "Hello Bob"

14    Put_Line (Buf);

15

16     --  Prints "Hi John"

17    Put_Line ("Hi " & Full_Name (1 .. 4));

18end Main;

Build output

main.adb:6:05: warning: "Full_Name" is not modified, could be declared constant [-gnatwk]

Runtime output

Hello Bob

Hi John

Как мы видим выше, вы можете использовать отрезок слева от присваивания, чтобы заменить только часть массива.

Отрезок массива имеет тот же тип, что и массив, но имеет другой подтип, ограниченния которого заданы границами отрезка.

Attention

В Ада есть многомерные массивы#1, которые не рассматриваются в этом курсе. Отрезки будут работать только с одномерными массивами.

Переименование

До сих пор мы видели, что следующие элементы могут быть переименованы: подпрограммы, пакеты и компоненты записи. Мы также можем переименовывать объекты с помощью ключевого слова renames. Это позволяет создавать альтернативные имена для данных объектов. Давайте посмотрим на пример:

measurements.ads

1package Measurements is

2

3   subtype Degree_Celsius is Float;

4

5   Current_Temperature : Degree_Celsius;

6

7end Measurements;

main.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Measurements;

3

4procedure Main is

5   subtype Degrees is Measurements.Degree_Celsius;

6

7   T : Degrees

8     renames Measurements.Current_Temperature;

9begin

10    T := 5.0;

11

12    Put_Line (Degrees'Image (T));

13    Put_Line (Degrees'Image

14      (Measurements.Current_Temperature));

15

16    T := T + 2.5;

17

18    Put_Line (Degrees'Image (T));

19    Put_Line (Degrees'Image

20      (Measurements.Current_Temperature));

21end Main;

Runtime output

5.00000E+00

5.00000E+00

7.50000E+00

7.50000E+00

В приведенном выше примере мы объявляем переменную T, переименовывая объект Current_Temperature из пакета Measurements. Как вы можете видеть, запустив этот пример, и Current_Temperature, и его альтернативное имя T имеют одинаковые значения:

- сначала они показывают значение 5.0

- после сложения они показывают значение 7.5.

Это потому, что они по существу обозначают однин и тот же объект, но с двумя разными именами.

Обратите внимание, что в приведенном выше примере мы используем Degrees как псевдоним Degree_Celsius. Мы обсуждали этот метод переименования ранее в курсе.

Переименование может быть полезно для улучшения читаемости кода со сложной индексацией массивов. Вместо того, чтобы явно использовать индексы каждый раз, когда мы обращаемся к определенным позициям массива, мы можем создавать короткие имена для этих позиций, переименовывая их. Давайте посмотрим на следующий пример:

colors.ads

1package Colors is

2

3   type Color is (Black, Red, Green, Blue, White);

4

5   type Color_Array is

6     array (Positive range <>) of Color;

7

8   procedure Reverse_It (X : in out Color_Array);

9

10end Colors;

colors.adb

1package body Colors is

2

3   procedure Reverse_It (X : in out Color_Array) is

4   begin

5      for I in X'First .. (X'Last + X'First) / 2 loop

6         declare

7            Tmp     : Color;

8            X_Left  : Color

9              renames X (I);

10            X_Right : Color

11              renames X (X'Last + X'First - I);

12         begin

13            Tmp     := X_Left;

14            X_Left  := X_Right;

15            X_Right := Tmp;

16         end;

17      end loop;

18   end Reverse_It;

19

20end Colors;

test_reverse_colors.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3with Colors; use Colors;

4

5procedure Test_Reverse_Colors is

6

7   My_Colors : Color_Array (1 .. 5) :=

8     (Black, Red, Green, Blue, White);

9

10begin

11   for C of My_Colors loop

12      Put_Line ("My_Color: " & Color'Image (C));

13   end loop;

14

15   New_Line;

16   Put_Line ("Reversing My_Color...");

17   New_Line;

18   Reverse_It (My_Colors);

19

20   for C of My_Colors loop

21      Put_Line ("My_Color: " & Color'Image (C));

22   end loop;

23

24end Test_Reverse_Colors;

Runtime output

My_Color: BLACK

My_Color: RED

My_Color: GREEN

My_Color: BLUE

My_Color: WHITE

Reversing My_Color...

My_Color: WHITE

My_Color: BLUE

My_Color: GREEN

My_Color: RED

My_Color: BLACK

В приведенном выше примере пакет Colors содержит процедуру Reverse_It, где объявлены новые имена для двух позиций массива. Таким образом реализация становится легко читаемой:

begin

Tmp     := X_Left;

X_Left  := X_Right;

X_Right := Tmp;

end;

Сравните это с альтернативной версией без переименования:

begin

Tmp                      := X (I);

X (I)                    := X (X'Last + X'First - I);

X (X'Last + X'First - I) := Tmp;

end;

Footnotes

#1

http://www.adaic.org/resources/add_content/standards/12rm/html/RM-3-6.html

Подробнее о типах

Агрегаты: краткая информация

До сих пор мы говорили об агрегатах довольно мало и видели лишь ряд примеров. Теперь мы рассмотрим эту конструкцию более подробно.

Агрегат в Аде фактически является литералом составного типа. Это очень мощная форма записи во многих случаях позволяет избежать написания процедурного кода для инициализации структур данных.

Основным правилом при записи агрегатов является то, что каждый компонент массива или записи должен быть указан, даже компоненты, которые имеют значение по умолчанию.

Это означает, что следующий код неверен:

incorrect.ads

1package Incorrect is

2   type Point is record

3      X, Y : Integer := 0;

4   end record;

5

6   Origin : Point := (X => 0);

7end Incorrect;

Build output

incorrect.ads:6:22: error: no value supplied for component "Y"

gprbuild: *** compilation phase failed

Существует несколько сокращений, которые можно использовать, чтобы сделать представление более удобным:

- Чтобы задать значение по умолчанию для компоненты, можно использовать нотацию <>.

- Символ | можно использовать для присвоения нескольким компонентам одинакового значения.

- Вы можете использовать others вариант для ссылки на все компоненты, которые еще не были указаны, при условии, что все эти поля имеют одинаковый тип.

- Можно использовать нотацию диапазона .. чтобы указать непрерывную последовательность индексов в массиве.

Однако следует отметить, что, как только вы использовали именованное сопоставление, все последующие компоненты также должны быть указаны с помощью именованного сопоставления.

points.ads

1package Points is

2   type Point is record

3      X, Y : Integer := 0;

4   end record;

5

6   type Point_Array is

7     array (Positive range <>) of Point;

8

9   --  use the default values

10   Origin   : Point := (X | Y => <>);

11

12   --  likewise, use the defaults

13   Origin_2 : Point := (others => <>);

14

15   Points_1 : Point_Array := ((1, 2), (3, 4));

16   Points_2 : Point_Array := (1       => (1, 2),

17                              2       => (3, 4),

18                              3 .. 20 => <>);

19end Points;

Cовмещение и квалифицированные выражения

В Ада есть общая концепция совмещения имен, которую мы видели ранее в разделе о перечислимых типах.

Давайте возьмем простой пример: в Аде возможно иметь функции с одинаковым именем, но разными типами для их параметров.

pkg.ads

1package Pkg is

2   function F (A : Integer) return Integer;

3   function F (A : Character) return Integer;

4end Pkg;

Это распространенное понятие в языках программирования, называемое совмещением, или перегрузкой имен#1.

Одной из особенностей совмещения имен в Аде является возможность разрешить неоднозначности на основе типа возвращаемого функцией.

pkg.ads

1package Pkg is

2   type SSID is new Integer;

3

4   function Convert (Self : SSID) return Integer;

5   function Convert (Self : SSID) return String;

6end Pkg;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Pkg;         use Pkg;

3

4procedure Main is

5   S : String := Convert (123_145_299);

6   --            ^ Valid, will choose the

7   --              proper Convert

8begin

9   Put_Line (S);

10end Main;

Attention

Заметим, что разрешение совмещения на основе типа в Аде работает как для функций, так и для литералов перечисления - вот почему у вас может быть несколько литералов перечисления с одинаковым именем. Семантически литерал перечисления рассматривается как функция, не имеющая параметров.

Однако иногда возникает двусмысленность из-за которой невозможно определить, к какому объявлению совмещенного имени относится данное употребление имени. Именно здесь становится полезным квалифицированное выражение.

pkg.ads

1package Pkg is

2   type SSID is new Integer;

3

4   function Convert (Self : SSID) return Integer;

5   function Convert (Self : SSID) return String;

6   function Convert (Self : Integer) return String;

7end Pkg;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Pkg;         use Pkg;

3

4procedure Main is

5   S : String := Convert (123_145_299);

6   --            ^ Invalid, which convert

7   --              should we call?

8

9   S2 : String := Convert (SSID'(123_145_299));

10   --                     ^ We specify that the

11   --                       type of the expression

12   --                       is SSID.

13

14   --  We could also have declared a temporary

15

16   I : SSID := 123_145_299;

17

18   S3 : String := Convert (I);

19begin

20   Put_Line (S);

21end Main;

Синтаксически квалифицированное выражение используется либо с выражением в круглых скобках, либо с агрегатом:

qual_expr.ads

1package Qual_Expr is

2   type Point is record

3      A, B : Integer;

4   end record;

5

6   P : Point := Point'(12, 15);

7

8   A : Integer := Integer'(12);

9end Qual_Expr;

Это иллюстрирует, что квалифицированные выражения являются удобным (а иногда и необходимым) способом явно обозначить тип выражения и помочь, как компилятору, так и для другим программистам разобраться в коде.

Attention

Хотя преобразования типов и квалифицированные выражения выглядят и ощущаются похожими это не одно и тоже.

Квалифицированное выражение указывает точный тип, в котором следует трактовать выражение, в то время как преобразование типа попытается преобразовать значение и выдаст ошибку во время выполнения, если исходное значение не может быть преобразовано.

Обратите внимание, что вы можете использовать квалифицированное выражение для преобразования из одного подтипа в другой, с исключением, возникающим при нарушении ограничения.

X : Integer := Natural'(1);

Символьные типы

Как отмечалось ранее, каждый перечислимый тип отличается и несовместим с любым другим перечислимым типом. Однако ранее мы не упоминали, что символьные литералы разрешены в качестве литералов перечисления. Это означает, что в дополнение к стандартным символьным типам пользователь может определить свои символьные типы:

character_example.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Character_Example is

4   type My_Char is ('a', 'b', 'c');

5   --  Our custom character type, an

6   --  enumeration type with 3 valid values.

7

8   C : Character;

9   --  ^ Built-in character type

10   --    (it's an enumeration type)

11

12   M : My_Char;

13begin

14   C := '?';

15   --   ^ Character literal

16   --     (enumeration literal)

17

18   M := 'a';

19

20   C := 65;

21   --   ^ Invalid: 65 is not a

22   --     Character value

23

24   C := Character'Val (65);

25   --  Assign the character at

26   --  position 65 in the

27   --  enumeration (which is 'A')

28

29   M := C;

30   --   ^ Invalid: C is of type Character,

31   --     and M is a My_Char

32

33   M := 'd';

34   --   ^ Invalid: 'd' is not a valid

35   --     literal for type My_Char

36end Character_Example;

Build output

character_example.adb:14:04: warning: useless assignment to "C", value overwritten at line 20 [-gnatwm]

character_example.adb:18:04: warning: useless assignment to "M", value overwritten at line 29 [-gnatwm]

character_example.adb:20:04: warning: useless assignment to "C", value overwritten at line 24 [-gnatwm]

character_example.adb:20:09: error: expected type "Standard.Character"

character_example.adb:20:09: error: found type universal integer

character_example.adb:29:04: warning: useless assignment to "M", value overwritten at line 33 [-gnatwm]

character_example.adb:29:09: error: expected type "My_Char" defined at line 4

character_example.adb:29:09: error: found type "Standard.Character"

character_example.adb:33:04: warning: possibly useless assignment to "M", value might not be referenced [-gnatwm]

character_example.adb:33:09: error: character not defined for type "My_Char" defined at line 4

gprbuild: *** compilation phase failed

Footnotes

#1

https://ru.m.wikipedia.org/wiki/Перегрузка_процедур_и_функций

Ссылочные типы (указатели)

Введение

Указатели - потенциально опасная конструкция, которая вступает в противоречие с основополагающей философией Ады.

Есть два способа, которыми Ада помогает оградить программистов от опасности указателей:

1. Один из подходов, который мы уже видели, заключается в обеспечении альтернативных возможностей, чтобы программисту не нужно было использовать указатели. Виды параметров, массивы и типы произвольных размеров - это все конструкции, которые могут заменить типичное использование указателей в C.

2. Во-вторых, Ада сделала указатели максимально безопасными и ограниченными, хотя допускает «аварийные люки», которые программист явно затребовать и, предположительно, будет использовать их с соответствующей осторожностью.

Вот как в Аде объявляется простой тип указателя, ссылочный тип:

dates.ads

1package Dates is

2   type Months is

3     (January, February, March, April,

4      May, June, July, August, September,

5      October, November, December);

6

7   type Date is record

8      Day   : Integer range 1 .. 31;

9      Month : Months;

10      Year  : Integer;

11   end record;

12end Dates;

access_types.ads

1with Dates; use Dates;

2

3package Access_Types is

4    --  Declare an access type

5    type Date_Acc is access Date;

6    --                      ^ "Designated type"

7    --                      ^ Date_Acc values point

8    --                        to Date objects

9

10    D : Date_Acc := null;

11    --              ^ Literal for

12    --                "access to nothing"

13    --  ^ Access to date

14end Access_Types;

На этом примере показано, как:

- Объявить ссылочный тип, значения которого указывают на объекты определенного типа

- Объявить переменную (для ссылочных значений) этого ссылочного типа

- Присвоить ему значение null

В соответствии с философией строгой типизации Ада, если объявить второй ссылочный тип, указывающий на Date, эти два ссылочных типа будут несовместимы друг с другом:

access_types.ads

1with Dates; use Dates;

2

3package Access_Types is

4    --  Declare an access type

5    type Date_Acc   is access Date;

6    type Date_Acc_2 is access Date;

7

8    D  : Date_Acc   := null;

9    D2 : Date_Acc_2 := D;

10    --                 ^ Invalid! Different types

11end Access_Types;

Build output

access_types.ads:9:24: error: expected type "Date_Acc_2" defined at line 6

access_types.ads:9:24: error: found type "Date_Acc" defined at line 5

gprbuild: *** compilation phase failed

На других языках

Большинство других языков используют структурно типизацию для указателей, что означает, что два типа указателей считаются одинаковыми, если они имеют один и тот же целевой тип.

В Аде это не так, и к этому, возможно, придется какое-то время привыкать. Казалось бы, простой вопрос, если вы хотите для вашего типа иметь канонический ссылочный тип, где его объявить? Обычно используют следующий подход, если понадобится ссылочный тип для некоторого вашего типа, то вы объявите его вместе с типом:

package Access_Types is

type Point is record

X, Y : Natural;

end record;

type Point_Access is access Point;

end Access_Types;

Выделение (allocation) памяти

После того, как мы объявили ссылочный тип, нам нужен способ присвоить переменным этого типа осмысленные значения! Вы можете получить значение ссылочного типа с помощью ключевого слова new.

access_types.ads

1with Dates; use Dates;

2

3package Access_Types is

4    type Date_Acc is access Date;

5

6    D : Date_Acc := new Date;

7    --              ^ Allocate a new Date record

8end Access_Types;

Если тип, память для значение которого требуется выделить, требует ограничений, их можно указать после подтипа, как в объявлении переменной:

access_types.ads

1with Dates; use Dates;

2

3package Access_Types is

4   type String_Acc is access String;

5   --                        ^

6   --  Access to unconstrained array type

7   Msg : String_Acc;

8   --    ^ Default value is null

9

10   Buffer : String_Acc :=

11     new String (1 .. 10);

12   --            ^ Constraint required

13end Access_Types;

Build output

access_types.ads:1:06: warning: no entities of "Dates" are referenced [-gnatwu]

access_types.ads:1:13: warning: use clause for package "Dates" has no effect [-gnatwu]

Однако, в некоторых случаях выделение памяти путем указания типа не является идеальным, поэтому Ада позволяет инициализировать объект одновременно с выделением памяти. Чтобы сделать это необходимо использовать квалифицированное выражение:

access_types.ads

1with Dates; use Dates;

2

3package Access_Types is

4   type Date_Acc is access Date;

5   type String_Acc is access String;

6

7   D   : Date_Acc   := new Date'(30, November, 2011);

8   Msg : String_Acc := new String'("Hello");

9end Access_Types;

Извлечение по ссылке

Последняя часть мозайки ссылочных типов языка Ада покажет нам, как получить значение объекту по ссылке, то есть как «разыменовать» указатель. Для этого в Аде используется синтаксис .all, но часто в нем вообще нет необходимости - во многих случаях использования ссылочного значения эта операция выполняется неявно:

access_types.ads

1with Dates; use Dates;

2

3package Access_Types is

4   type Date_Acc is access Date;

5

6   D     : Date_Acc := new Date'(30, November, 2011);

7

8   Today : Date := D.all;

9   --              ^ Access value dereference

10   J     : Integer := D.Day;

11   --                 ^ Implicit dereference for

12   --                   record and array components

13   --                   Equivalent to D.all.day

14end Access_Types;

Другие особенности

Как вы, возможно, заметили, если пользовались указатели в C или C++, мы не показали некоторых функций, которые считаются основополагающими при использования указателей, таких как:

- Арифметика над указателями (возможность увеличивать или уменьшать указатель, чтобы переместить его на следующий или предыдущий объект)

- Освобождение памяти вручную - то, что в C делается с помощью free или delete. Это потенциально опасная операция. Чтобы оставаться в безопасном пространстве Ады, вам лучше не освобождать память вручную.

Эти функции существуют в Аде, но воспользоваться ими можно только с помощью определенных интерфейсов стандартной библиотеки (API).

Attention

Общепринятый принцип языка гласит, что в большенстве случаев вы можете избегать ручного управления памятью, и вам лучше следовать ему.

Существует множество способов избежать распределения памяти вручную, с некоторыми из них мы уже встречались (например, виды параметров). Язык также предоставляет библиотечные абстракции, чтобы избежать указателей:

1. Одним из них является использование контейнеров. Контейнеры помогают пользователям избегать указателей, поскольку сами управляют памятью.

2. Контейнер, который следует отметить в этом контексте, является Indefinite holder#1. Этот контейнер позволяет хранить значение неопределенного типа, например String.

3. GNATCOLL🤢 имеет библиотеку для интеллектуальных указателей, называемую Refcount#2, память этих указателей автоматически управляется, так что, когда у выделенного объекта больше нет ссылок на него, память автоматически освобождается.

Взаимно рекурсивные типы

Связанный список является широко известной идиомой в программировании; в Аде его наиболее естественная запись включает определение двух типов - тип записи и ссфлочный тип, которые будут взаимно зависимыми. Для объявления взаимно зависимых типов можно использовать неполное объявление типа:

simple_list.ads

1package Simple_List is

2   type Node;

3   --  This is an incomplete type declaration,

4   --  which is completed in the same

5   --  declarative region.

6

7   type Node_Acc is access Node;

8

9   type Node is record

10      Content    : Natural;

11      Prev, Next : Node_Acc;

12   end record;

13end Simple_List;

Footnotes

#1

http://www.ada-auth.org/standards/12rat/html/Rat12-8-5.html

#2

https://github.com/AdaCore/gnatcoll-core/blob/master/src/gnatcoll-refcount.ads

Подробнее о записях

Типы записей динамически изменяемого размера

Ранее мы видели несколько простых примеров типов записей. Давайте рассмотрим некоторые из более продвинутых возможностей этой фундаментальной конструкции языка Ада.

Следует отметить, что размер объекта для типа записи не обязательно должен быть известен во время компиляции. Это проиллюстрировано в приведенном ниже примере:

runtime_length.ads

1package Runtime_Length is

2   function Compute_Max_Len return Natural;

3end Runtime_Length;

var_size_record.ads

1with Runtime_Length; use Runtime_Length;

2

3package Var_Size_Record is

4    Max_Len : constant Natural

5      := Compute_Max_Len;

6    --   ^ Not known at compile time

7

8    type Items_Array is array (Positive range <>)

9      of Integer;

10

11    type Growable_Stack is record

12       Items : Items_Array (1 .. Max_Len);

13       Len   : Natural;

14    end record;

15    --  Growable_Stack is a definite type, but

16    --  size is not known at compile time.

17

18    G : Growable_Stack;

19end Var_Size_Record;

Совершенно нормально определять размер ваших записей во время выполнения, но учтите, что все объекты этого типа будут иметь одинаковый размер.

Записи с дискриминантом

В приведенном выше примере размер поля Items определяется один раз во время выполнения, но размер всех экземпляров Growable_Stack будет совпадать. И, возможно, это не то, что вы хотите получить. Мы видели, что массивы в целом имеют такую гибкость: для неограниченного типа массива разные объекты могут иметь разные размеры.

Получить аналогичную функциональность для записей можно используя специальную разновидность компонент, которые называются дискриминантами:

var_size_record_2.ads

1package Var_Size_Record_2 is

2    type Items_Array is array (Positive range <>)

3      of Integer;

4

5    type Growable_Stack (Max_Len : Natural) is

6    record

7    --                   ^ Discriminant. Cannot be

8    --                     modified once initialized.

9       Items : Items_Array (1 .. Max_Len);

10       Len   : Natural := 0;

11    end record;

12    --  Growable_Stack is an indefinite type

13    --  (like an array)

14end Var_Size_Record_2;

Дискриминанты, грубо говоря, являются константами: вы не можете изменять их значение после инициализации объекта. Это интуитивно понятно, поскольку они определяют размер объекта.

Кроме того, они делают тип неопределенным. В независимости от того, используется ли дискриминант для указания размера объекта или нет, тип с дискриминантом считается неопределенным, пока дискриминант не имеет выражение для инициализации:

test_discriminants.ads

1package Test_Discriminants is

2   type Point (X, Y : Natural) is record

3      null;

4   end record;

5

6   P : Point;

7   --  ERROR: Point is indefinite, so you

8   --  need to specify the discriminants

9   --  or give a default value

10

11   P2 : Point (1, 2);

12   P3 : Point := (1, 2);

13   --  Those two declarations are equivalent.

14

15end Test_Discriminants;

Build output

test_discriminants.ads:6:08: error: unconstrained subtype not allowed (need initialization)

test_discriminants.ads:6:08: error: provide initial value or explicit discriminant values

test_discriminants.ads:6:08: error: or give default discriminant values for type "Point"

gprbuild: *** compilation phase failed

Это также означает, что в приведенном выше примере вы не можете объявить массив значений Point, потому что размер Point неизвестен.

Как упоминалось выше, мы могли бы предоставить значение по умолчанию для дискриминантов, чтобы легально объявлять переменные типа Point без указания значения дискриминантов. В приведенном выше примере это будет выглядеть так:

test_discriminants.ads

1package Test_Discriminants is

2   type Point (X, Y : Natural := 0) is record

3      null;

4   end record;

5

6   P : Point;

7   --  We can now simply declare a "Point"

8   --  without further ado. In this case,

9   --  we're using the default values (0)

10   --  for X and Y.

11

12   P2 : Point (1, 2);

13   P3 : Point := (1, 2);

14   --  We can still specify discriminants.

15

16end Test_Discriminants;

Также обратите внимание, что, хотя тип Point теперь имеет дискриминанты по умолчанию, это не мешает нам указывать дискриминанты, как мы это делаем в объявлениях P2 и P3.

Во многих других отношениях дискриминанты ведут себя как обычные поля: вы должны указать их значения в агрегатах, как показано выше, и вы можете извлекать их значения с помощью точечной нотации.

main.adb

1with Var_Size_Record_2; use Var_Size_Record_2;

2with Ada.Text_IO; use Ada.Text_IO;

3

4procedure Main is

5   procedure Print_Stack (G : Growable_Stack) is

6   begin

7      Put ("<Stack, items: [");

8      for I in G.Items'Range loop

9         exit when I > G.Len;

10         Put (" " & Integer'Image (G.Items (I)));

11      end loop;

12      Put_Line ("]>");

13   end Print_Stack;

14

15   S : Growable_Stack :=

16     (Max_Len => 128,

17      Items   => (1, 2, 3, 4, others => <>),

18      Len     => 4);

19begin

20   Print_Stack (S);

21end Main;

Build output

main.adb:15:04: warning: "S" is not modified, could be declared constant [-gnatwk]

Runtime output

<Stack, items: [  1  2  3  4]>

Note

В примере выше, мы использовали дискриминант чтобы указать размер массива, но возможны и другие применения, например, определение дискриминанта вложенной записи.

Записи c вариантами

Ранее мы привели примеры использования дискриминантов для объявление записей разлного размера, содержащих компоненты, размер которых зависит от дискриминанта.

Но с помощью дискриминантов также можно построить конструкцию часто именуемую «запись с вариантами»: это записи, которые могут содержать разные наборы полей.

variant_record.ads

1package Variant_Record is

2   --  Forward declaration of Expr

3   type Expr;

4

5   --  Access to a Expr

6   type Expr_Access is access Expr;

7

8   type Expr_Kind_Type is (Bin_Op_Plus,

9                           Bin_Op_Minus,

10                           Num);

11   --  A regular enumeration type

12

13   type Expr (Kind : Expr_Kind_Type) is record

14      --      ^ The discriminant is an

15      --        enumeration value

16      case Kind is

17         when Bin_Op_Plus | Bin_Op_Minus =>

18            Left, Right : Expr_Access;

19         when Num =>

20            Val : Integer;

21      end case;

22      --  Variant part. Only one, at the end of

23      --  the record definition, but can be

24      --  nested

25   end record;

26end Variant_Record;

Поля, которые находятся в варианте when, будут доступны только тогда, когда значение дискриминанта совпадает с указанным. В приведенном выше примере вы сможете обращаться к полям Left и Right, только если Kind равен Bin_Op_Plus или Bin_Op_Minus.

Если вы попытаетесь получить доступ к полю, когда значение дискриминанта не совпадает, будет возбуждено исключение Constraint_Error.

main.adb

1with Variant_Record; use Variant_Record;

2

3procedure Main is

4   E : Expr := (Num, 12);

5begin

6   E.Left := new Expr'(Num, 15);

7   --  Will compile but fail at runtime

8end Main;

Build output

main.adb:4:04: warning: variable "E" is not referenced [-gnatwu]

main.adb:6:05: warning: component not present in subtype of "Expr" defined at line 4 [enabled by default]

main.adb:6:05: warning: "Constraint_Error" will be raised at run time [enabled by default]

Runtime output

raised CONSTRAINT_ERROR : main.adb:6 discriminant check failed

А вот как можно написать вычислитель выражений:

main.adb

1with Variant_Record; use Variant_Record;

2with Ada.Text_IO; use Ada.Text_IO;

3

4procedure Main is

5   function Eval_Expr (E : Expr) return Integer is

6     (case E.Kind is

7      when Bin_Op_Plus  => Eval_Expr (E.Left.all)

8                           + Eval_Expr (E.Right.all),

9      when Bin_Op_Minus => Eval_Expr (E.Left.all)

10                           - Eval_Expr (E.Right.all),

11      when Num => E.Val);

12

13   E : Expr := (Bin_Op_Plus,

14                new Expr'(Bin_Op_Minus,

15                          new Expr'(Num, 12),

16                          new Expr'(Num, 15)),

17                new Expr'(Num, 3));

18begin

19   Put_Line (Integer'Image (Eval_Expr (E)));

20end Main;

Build output

main.adb:13:04: warning: "E" is not modified, could be declared constant [-gnatwk]

Runtime output

0

На других языках

Записи вариантов Аде очень похожи на Sum типы в функциональных языках, таких как OCaml или Haskell. Основное отличие состоит в том, что дискриминант является отдельным полем в Аде, тогда как «тег» Sum типа является встроенным и доступен только при сопаставлении шаблонов.

Есть и другие различия (записи с вариантами в Аде могут иметь несколько дискриминантов). Тем не менее, они допускают тот же подход к моделированию, что и типы Sum функциональных языков.

По сравнению с объединениями C/C++ записи с вариантами Аде более мощны, а также благодаря проверкам во время выполнения, более безопасны.

Footnotes

Типы с фиксированной запятой

Десятичные типы с фиксированной запятой

Мы уже видели, как определять типы с плавающей запятой. Однако в некоторых приложениях плавающая запятая не подходит, например, ошибка округления при двоичной арифметики неприемлема или, оборудование не поддерживает инструкции с плавающей запятой. В языке Ада есть десятичные типы с фиксированной запятой, которые позволяют программисту указать требуемую десятичную точность (количество цифр), а также коэффициент масштабирования (степень десяти) и, необязательно, диапазон. Фактически, значения такого типа будут представлены как целые числа, неявно масштабированные с указанной степенью 10. Это полезно, например, для финансовых приложений.

Синтаксис простого десятичного типа с фиксированной запятой:

type <type-name> is delta <delta-value> digits <digits-value>;

В этом случае delta и digits будут использоваться компилятором для вычисления диапазона значений.

Несколько атрибутов полезны при работе с десятичными типами:

Имя атрибута

Значение

First

Наименьшее значение типа

Last

Наибольшее значение типа

Delta

Значение минимального шага типа

В приведенном ниже примере мы объявляем два типа данных: T3_D3 и T6_D3. Для обоих типов значение дельты одинаково: 0.001.

decimal_fixed_point_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Decimal_Fixed_Point_Types is

4   type T3_D3 is delta 10.0 ** (-3) digits 3;

5   type T6_D3 is delta 10.0 ** (-3) digits 6;

6begin

7   Put_Line ("The delta    value of T3_D3 is "

8             & T3_D3'Image (T3_D3'Delta));

9   Put_Line ("The minimum  value of T3_D3 is "

10             & T3_D3'Image (T3_D3'First));

11   Put_Line ("The maximum  value of T3_D3 is "

12             & T3_D3'Image (T3_D3'Last));

13   New_Line;

14

15   Put_Line ("The delta    value of T6_D3 is "

16             & T6_D3'Image (T6_D3'Delta));

17   Put_Line ("The minimum  value of T6_D3 is "

18             & T6_D3'Image (T6_D3'First));

19   Put_Line ("The maximum  value of T6_D3 is "

20             & T6_D3'Image (T6_D3'Last));

21end Decimal_Fixed_Point_Types;

Runtime output

The delta    value of T3_D3 is  0.001

The minimum  value of T3_D3 is -0.999

The maximum  value of T3_D3 is  0.999

The delta    value of T6_D3 is  0.001

The minimum  value of T6_D3 is -999.999

The maximum  value of T6_D3 is  999.999

При запуске приложения мы видим, что значение дельты обоих типов действительно одинаково: 0.001. Однако, поскольку T3_D3 ограничен 3 цифрами, его диапазон составляет от -0,999 до 0,999. Для T6_D3 мы определили точность 6 цифр, поэтому диапазон от -999,999 до 999,999.

Аналогично определению типа с использованием синтаксиса диапазона (range), поскольку у нас есть неявный диапазон, скомпилированный код будет проверять, что переменные содержат значения, не выходящие за пределы диапазона. Кроме того, если результат умножения или деления десятичных типов с фиксированной запятой меньше, чем значение дельты, известное из контекста, фактический результат будет равен нулю. Например:

decimal_fixed_point_smaller.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Decimal_Fixed_Point_Smaller is

4   type T3_D3 is delta 10.0 ** (-3) digits 3;

5   type T6_D6 is delta 10.0 ** (-6) digits 6;

6   A : T3_D3 := T3_D3'Delta;

7   B : T3_D3 := 0.5;

8   C : T6_D6;

9begin

10   Put_Line ("The value of A     is "

11             & T3_D3'Image (A));

12

13   A := A * B;

14   Put_Line ("The value of A * B is "

15             & T3_D3'Image (A));

16

17   A := T3_D3'Delta;

18   C := A * B;

19   Put_Line ("The value of A * B is "

20             & T6_D6'Image (C));

21end Decimal_Fixed_Point_Smaller;

Build output

decimal_fixed_point_smaller.adb:7:04: warning: "B" is not modified, could be declared constant [-gnatwk]

Runtime output

The value of A     is  0.001

The value of A * B is  0.000

The value of A * B is  0.000500

В этом примере, результат операции 0.001 * 0.5 будет 0.0005. Ввиду того, что это значение не может быть представленно типом T3_D3 ведь его дельта равна 0.001, реальное значение которое получит переменная A будет равно нулю. Однако, если тип имеет большую точность, то точности арифметических операций будет достаточно, и значение C будет равно 0.000500.

Обычные типы с фиксированной запятой

Обычные типы с фиксированной запятой похожи на десятичные типы с фиксированной запятой в том, что значения, по сути, являются масштабированными целыми числами. Разница между ними заключается в коэффициенте масштабирования: для десятичного типа с фиксированной запятой масштабирование, явно заданное дельтой (delta), всегда является степенью десяти.

Напротив, для обычного типа с фиксированной запятой масштабирование определяется значением small для типа, которое получается из указанного значения delta и, по умолчанию, является степенью двойки. Поэтому обычные типы с фиксированной запятой иногда называют двоичными типами с фиксированной запятой.

Note

Обычные типы с фиксированной запятой можно рассматривать как более близкие к реальному представлению на машине, поскольку аппаратная поддержка десятичной арифметики с фиксированной запятой не получила широкого распространения (изменение масштаба в десять раз), в то время как обычные типы с фиксированной запятой доступных используют широко распространенные инструкций целочисленного сдвига.

Синтаксис обычного типа с фиксированной запятой:

type <type-name> is

delta <delta-value>

range <lower-bound> .. <upper-bound>;

По умолчанию компилятор выберет коэффициент масштабирования, или small, то есть степень 2, не превышающую <delta-value>.

Например, можно определить нормализованный диапазон между -1.0 и 1.0 следующим образом:

normalized_fixed_point_type.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Normalized_Fixed_Point_Type is

4   D : constant := 2.0 ** (-31);

5   type TQ31 is delta D range -1.0 .. 1.0 - D;

6begin

7   Put_Line ("TQ31 requires "

8             & Integer'Image (TQ31'Size)

9             & " bits");

10   Put_Line ("The delta    value of TQ31 is "

11             & TQ31'Image (TQ31'Delta));

12   Put_Line ("The minimum  value of TQ31 is "

13             & TQ31'Image (TQ31'First));

14   Put_Line ("The maximum  value of TQ31 is "

15             & TQ31'Image (TQ31'Last));

16end Normalized_Fixed_Point_Type;

Runtime output

TQ31 requires  32 bits

The delta    value of TQ31 is  0.0000000005

The minimum  value of TQ31 is -1.0000000000

The maximum  value of TQ31 is  0.9999999995

В этом примере мы определяем 32-разрядный тип данных с фиксированной запятой для нормализованного диапазона. При запуске приложения мы замечаем, что верхняя граница близка к единице, но не ровна. Это типичный эффект типов данных с фиксированной запятой - более подробную информацию можно найти в этом обсуждении Q формата#1. Мы также можем переписать этот код определения типа:

normalized_adapted_fixed_point_type.adb

1procedure Normalized_Adapted_Fixed_Point_Type is

2   type TQ31 is

3     delta 2.0 ** (-31)

4     range -1.0 .. 1.0 - 2.0 ** (-31);

5begin

6   null;

7end Normalized_Adapted_Fixed_Point_Type;

Build output

normalized_adapted_fixed_point_type.adb:2:09: warning: type "TQ31" is not referenced [-gnatwu]

Мы также можем использовать любой другой диапазон. Например:

custom_fixed_point_range.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Ada.Numerics; use Ada.Numerics;

3

4procedure Custom_Fixed_Point_Range is

5   type T_Inv_Trig is

6     delta 2.0 ** (-15) * Pi

7     range -Pi / 2.0 .. Pi / 2.0;

8begin

9   Put_Line ("T_Inv_Trig requires "

10             & Integer'Image (T_Inv_Trig'Size)

11             & " bits");

12   Put_Line ("The delta    value of T_Inv_Trig is "

13             & T_Inv_Trig'Image (T_Inv_Trig'Delta));

14   Put_Line ("The minimum  value of T_Inv_Trig is "

15             & T_Inv_Trig'Image (T_Inv_Trig'First));

16   Put_Line ("The maximum  value of T_Inv_Trig is "

17             & T_Inv_Trig'Image (T_Inv_Trig'Last));

18end Custom_Fixed_Point_Range;

Build output

custom_fixed_point_range.adb:13:44: warning: static fixed-point value is not a multiple of Small [-gnatwb]

Runtime output

T_Inv_Trig requires  16 bits

The delta    value of T_Inv_Trig is  0.00006

The minimum  value of T_Inv_Trig is -1.57080

The maximum  value of T_Inv_Trig is  1.57080

В этом примере мы определяем 16-разрядный тип с именем T_Inv_Trig, который имеет диапазон от −𝜋/2 до 𝜋/2.

Для типов с фиксированной запятой доступны все общепринятые операции. Например:

fixed_point_op.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Fixed_Point_Op is

4   type TQ31 is

5     delta 2.0 ** (-31)

6     range -1.0 .. 1.0 - 2.0 ** (-31);

7

8   A, B, R : TQ31;

9begin

10   A := 0.25;

11   B := 0.50;

12   R := A + B;

13   Put_Line ("R is " & TQ31'Image (R));

14end Fixed_Point_Op;

Runtime output

R is  0.7500000000

Как и ожидалось, R содержит 0,75 после сложения A и B.

На самом деле язык является более гибким, чем показано в этих примерах, поскольку на практике обычно необходимо умножать или делить значения различных типов с фиксированной запятой и получать результат, который может быть третьего типа. Подробная информация выходит за рамки данного вводного курса.

Следует также отметить, что, хотя подробности также выходят за рамки данного курса, можно явно указать значение small для обычного типа с фиксированной точкой. Это позволяет осуществлять недвоичное масштабирование, например:

type Angle is

delta 1.0/3600.0

range 0.0 .. 360.0 - 1.0 / 3600.0;

for Angle'Small use Angle'Delta;

Footnotes

#1

https://en.wikipedia.org/wiki/Q_(number_format)

Изоляция

Одним из основных положений модульного программирования, а также объектно-ориентированного программирования, является инкапсуляция#1.

Инкапсуляция, вкратце, является концепцией, следуя которой разработчик программного обеспечения разделяет общедоступный интерфейс подсистемы и ее внутреннюю реализацию.

Это касается не только библиотек программного обеспечения, но и всего, где используются абстракции.

Ада несколько отличается от большинства объектно-ориентированных языков, тем что границы инкапсуляции в основном проходят по границам пакетов.

Простейшая инкапсуляция

encapsulate.ads

1package Encapsulate is

2   procedure Hello;

3

4private

5

6   procedure Hello2;

7   --  Not visible from external units

8end Encapsulate;

encapsulate.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Encapsulate is

4

5   procedure Hello is

6   begin

7      Put_Line ("Hello");

8   end Hello;

9

10   procedure Hello2 is

11   begin

12      Put_Line ("Hello #2");

13   end Hello2;

14

15end Encapsulate;

main.adb

1with Encapsulate;

2

3procedure Main is

4begin

5   Encapsulate.Hello;

6   Encapsulate.Hello2;

7   --  Invalid: Hello2 is not visible

8end Main;

Build output

main.adb:6:15: error: "Hello2" is not a visible entity of "Encapsulate"

gprbuild: *** compilation phase failed

Абстрактные типы данных

С таким высокоуровневым механизмом инкапсуляции может быть неочевидно, как скрыть детали реализации одного типа. Вот как это можно сделать в Аде:

stacks.ads

1package Stacks is

2   type Stack is private;

3   --  Declare a private type: You cannot depend

4   --  on its implementation. You can only assign

5   --  and test for equality.

6

7   procedure Push (S   : in out Stack;

8                   Val :        Integer);

9   procedure Pop (S   : in out Stack;

10                  Val :    out Integer);

11private

12

13   subtype Stack_Index is Natural range 1 .. 10;

14   type Content_Type is array (Stack_Index)

15     of Natural;

16

17   type Stack is record

18      Top     : Stack_Index;

19      Content : Content_Type;

20   end record;

21end Stacks;

stacks.adb

1package body Stacks is

2

3   procedure Push (S   : in out Stack;

4                   Val :        Integer) is

5   begin

6      --  Missing implementation!

7      null;

8   end Push;

9

10   procedure Pop (S   : in out Stack;

11                  Val :    out Integer) is

12   begin

13      --  Dummy implementation!

14      Val := 0;

15   end Pop;

16

17end Stacks;

В приведенном выше примере мы определяем тип для стека в публичной части (известной как видимый раздел спецификации пакета в Аде), но детали реализация этого типа скрыты.

Затем в личном разделе мы определяем реализацию этого типа. Мы также можем объявить там другие вспомогательные типы, которые будут использованы для описания основного публичного типа. Создание вспомогательных типов - это полезная и распространенная практика в Аде.

Несколько слов о терминологии:

- То, как выглядит тип стека Stack в видимом разделе, называется частичным представлением типа. Это то, к чему имеют доступ клиенты.

- То, как выглядит тип стека Stack из личного раздела или тела пакета, называется полным представлением типа. Это то, к чему имеют доступ разработчики.

С точки зрения клиента (указывающего пакет в with) важен только видимый раздел, и личного вообще может не существовать. Это позволяет очень легко просмотреть ту часть пакета, которая важна для нас.

--  No need to read the private part to use the package

package Stacks is

type Stack is private;

procedure Push (S   : in out Stack;

Val :        Integer);

procedure Pop (S   : in out Stack;

Val :    out Integer);

private

...

end Stacks;

А вот как будет использоваться пакет Stacks:

--  Example of use

with Stacks; use Stacks;

procedure Test_Stack is

S : Stack;

Res : Integer;

begin

Push (S, 5);

Push (S, 7);

Pop (S, Res);

end Test_Stack;

Лимитируемые типы

В Аде конструкция лимитируемого типа позволяет вам объявить тип, для которого операции присваивания и сравнения не предоставляются автоматически.

stacks.ads

1package Stacks is

2   type Stack is limited private;

3   --  Limited type. Cannot assign nor compare.

4

5   procedure Push (S   : in out Stack;

6                   Val :        Integer);

7   procedure Pop (S   : in out Stack;

8                  Val :    out Integer);

9private

10   subtype Stack_Index is Natural range 1 .. 10;

11   type Content_Type is

12     array (Stack_Index) of Natural;

13

14   type Stack is limited record

15      Top     : Stack_Index;

16      Content : Content_Type;

17   end record;

18end Stacks;

stacks.adb

1package body Stacks is

2

3   procedure Push (S   : in out Stack;

4                   Val :        Integer) is

5   begin

6      --  Missing implementation!

7      null;

8   end Push;

9

10   procedure Pop (S   : in out Stack;

11                  Val :    out Integer) is

12   begin

13      --  Dummy implementation!

14      Val := 0;

15   end Pop;

16

17end Stacks;

main.adb

1with Stacks; use Stacks;

2

3procedure Main is

4   S, S2 : Stack;

5begin

6   S := S2;

7   --  Illegal: S is limited.

8end Main;

Build output

stacks.adb:10:19: warning: formal parameter "S" is not referenced [-gnatwf]

main.adb:6:04: error: left hand of assignment must not be limited type

gprbuild: *** compilation phase failed

Это нужно, например, для тех типов данных, для которых встроенная операция присваивания работает неправильно (например, когда требуется многоуровневевое копирование).

Ада позволяет вам определить операторы сравнения = и /= для лимитируемых типов (или переопределить встроенные объявления для нелимитируемых).

Ада также позволяет вам предоставить собственную реализацию присваивания используя контролируемые типы#2. Однако в некоторых случаях операция присваивания просто не имеет смысла; примером может служить File_Type из пакета Ada.Text_IO, который объявлен как лимитируемый тип, и поэтому все попытки присвоить один файл другому будут отклонены как незаконные.

Дочерние пакеты и изоляция

Ранее мы видели (в разделе дочерние пакеты), что пакеты могут иметь дочерние пакеты. Изоляция играет важную роль в дочерних пакетах. В этом разделе обсуждаются некоторые правила касающиеся изоляции, действующие для дочерних пакетов.

Хотя личный раздел P предназначен для инкапсуляции информации, некоторые части дочернего пакета P.C могут иметь доступ к этому личному разделу P. В таких случаях информация из личного раздела P может затем использоваться так, как если бы она была объявлена в видимом разделе спецификации пакета. Говоря более конкретно, тело P.C и личный раздел пакета P.C имеют доступ к личному разделу P. Однако видимый раздел спецификации P.C имеет доступ только к видимому разделу спецификации P. В следующей таблице приводится сводная информация об этом:

Часть дочернего пакета

Доступ к личному разделу родительской спецификации

Спецификация: видимый раздел

Нет

Спецификация: личный раздел

Да

Тело

Да

В оставшейся части этого раздела показаны примеры того, как этот доступ к личной информации на самом деле работает для дочерних пакетов.

Давайте сначала рассмотрим пример, в котором тело дочернего пакета P.C имеет доступ к личному разделу спецификации его родителя P. В предыдущем примере исходного кода мы видели, что процедуру Hello2, объявленную в личном разделе пакета Encapsulate нельзя использовать в процедуре Main, поскольку ее там не видно. Однако это ограничение не распространяется на некоторые части дочерних пакетов. Фактически, тело дочернего пакета Encapsulate.Child имеет доступ к процедуре Hello2 и она может быть вызыванна оттуда, как вы можете видеть в реализации процедуры Hello3 пакета Child:

encapsulate.ads

1package Encapsulate is

2   procedure Hello;

3

4private

5

6   procedure Hello2;

7   --  Not visible from external units

8   --  But visible in child packages

9end Encapsulate;

encapsulate.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Encapsulate is

4

5   procedure Hello is

6   begin

7      Put_Line ("Hello");

8   end Hello;

9

10   procedure Hello2 is

11   begin

12      Put_Line ("Hello #2");

13   end Hello2;

14

15end Encapsulate;

encapsulate-child.ads

1package Encapsulate.Child is

2

3   procedure Hello3;

4

5end Encapsulate.Child;

encapsulate-child.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Encapsulate.Child is

4

5   procedure Hello3 is

6   begin

7      --  Using private procedure Hello2

8      --  from the parent package

9      Hello2;

10      Put_Line ("Hello #3");

11   end Hello3;

12

13end Encapsulate.Child;

main.adb

1with Encapsulate.Child;

2

3procedure Main is

4begin

5   Encapsulate.Child.Hello3;

6end Main;

Runtime output

Hello #2

Hello #3

Тот же механизм применяется к типам, объявленным в личном разделе родительского пакета. Например, тело дочернего пакета может получить доступ к компонентам записи, объявленной в личном разделе его родительского пакета. Рассмотрим пример:

my_types.ads

1package My_Types is

2

3   type Priv_Rec is private;

4

5private

6

7   type Priv_Rec is record

8     Number : Integer := 42;

9   end record;

10

11end My_Types;

my_types-ops.ads

1package My_Types.Ops is

2

3   procedure Display (E : Priv_Rec);

4

5end My_Types.Ops;

my_types-ops.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body My_Types.Ops is

4

5   procedure Display (E : Priv_Rec) is

6   begin

7      Put_Line ("Priv_Rec.Number: "

8                & Integer'Image (E.Number));

9   end Display;

10

11end My_Types.Ops;

main.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2

3with My_Types;     use My_Types;

4with My_Types.Ops; use My_Types.Ops;

5

6procedure Main is

7   E : Priv_Rec;

8begin

9   Put_Line ("Presenting information:");

10

11   --  The following code would trigger a

12   --  compilation error here:

13   --

14   --  Put_Line ("Priv_Rec.Number: "

15   --            & Integer'Image (E.Number));

16

17   Display (E);

18end Main;

Runtime output

Presenting information:

Priv_Rec.Number:  42

В этом примере у нас нет доступа к компоненте Number типа записи Priv_Rec в процедуре Main. Вы можете увидеть это в вызове Put_Line, который был закомментирован в реализации Main. Попытка получить доступ к компоненте Number вызовет ошибку компиляции. Но у нас есть доступ к этой компоненте в теле пакета My_Types.Ops, поскольку это дочерний пакет пакета My_Types. Следовательно, тело Ops имеет доступ к объявлению типа Priv_Rec, которое находится в личном разделе его родительского пакета My_Types. По этой причине тот же вызов Put_Line, который вызовет ошибку компиляции в процедуре Main, отлично работает в процедуре Display пакета My_Types.Ops.

Такой рода правила изоляции для дочерних пакетов позволяют расширять функциональность родительского пакета и в то же время обеспечивают инкапсуляцию.

Как мы упоминали ранее, в дополнение к телу пакета личный раздел спецификации дочернего пакета P.C также имеет доступ к личному разделу спецификации его родителя P. Давайте посмотрим на пример, в котором мы объявляем объект личного типа Priv_Rec в личном разделе дочернего пакета My_Types.Child и напрямую инициализируем компоненту Number записи Priv_Rec:

package My_Types.Child is

private

E : Priv_Rec := (Number => 99);

end My_Types.Ops;

Естественно, мы не смогли бы инициализировать этот компонент, если бы переместили это объявление в общедоступный (видимый) раздел того же дочернего пакета:

package My_Types.Child is

E : Priv_Rec := (Number => 99);

end My_Types.Ops;

Объявление выше вызывает ошибку компиляции, поскольку тип Priv_Rec является личным. Поскольку видимый раздел My_Types.Child также виден за пределами дочернего пакета, Ада запрещает доступ к личной информации в этом разделе спецификации.

Footnotes

#1

https://ru.wikipedia.org/wiki/Инкапсуляция_(программирование)

#2

https://www.adaic.org/resources/add_content/standards/12rm/html/RM-7-6.html

Настраиваемые модули

Введение

Настраиваемые модули в Аде используются для метапрограммирования. Когда некоторые алгоритмы имеют достаточно много общего и отличаются лишь деталями, можно выделить абстрактный алгоритм воспользовавшись возможностями настраиваемых модулей.

Настраиваемыми могут быть лишь подпрограммы или пакеты. Объявление настраиваемого модуля начинается с ключевого слова generic. Например:

operator.ads

1generic

2   type T is private;

3   --  Declaration of formal types and objects

4--  Below, we could use one of the following:

5--  <procedure | function | package>

6procedure Operator (Dummy : in out T);

operator.adb

1procedure Operator (Dummy : in out T) is

2begin

3   null;

4end Operator;

Объявление формального типа

Формальные типы - это абстракции типа некоторого класса. Например, мы можем понадобиться создать алгоритм, который работает с любым целочисленным типом или даже с любым типом вообще, будь то числовой тип или нет. В следующем примере объявляется формальный тип T для процедуры Set.

set.ads

1generic

2   type T is private;

3   --  T is a formal type that indicates that

4   --  any type can be used, possibly a numeric

5   --  type or possibly even a record type.

6procedure Set (Dummy : T);

set.adb

1procedure Set (Dummy : T) is

2begin

3   null;

4end Set;

Объявление T как private указывает на то, что на его месте может быть любой определенный тип. Но также можно сузить условие, разрешив подстановку типов лишь некоторого класса. Вот несколько примеров:

Формальный тип

Формат

Любой тип

type T is private;

Любой дискретный тип

type T is (<>);

Любой тип с плавающей запятой

type T is digits <>;

Объявление формального объекта

Формальные объекты аналогичны параметрам подпрограммы. Они могут ссылаться на формальные типы, объявленные в формальной спецификации. Например:

set.ads

1generic

2   type T is private;

3   X : in out T;

4   --  X can be used in the Set procedure

5procedure Set (E : T);

set.adb

1procedure Set (E : T) is

2   pragma Unreferenced (E, X);

3begin

4   null;

5end Set;

Формальные объекты могут быть либо входными параметрами, либо иметь вид in out.

Определение тела настраиваемого модуля

Не нужно повторять ключевое слово generic при объявления тела настраиваемой подпрограммы или пакета. Для реализации мы используем синтаксис, как у обычного тела модуля, и используем объявленные выше формальные типы и объекты. Например:

set.ads

1generic

2   type T is private;

3   X : in out T;

4procedure Set (E : T);

set.adb

1procedure Set (E : T) is

2--  Body definition: "generic" keyword

3--  is not used

4begin

5   X := E;

6end Set;

Конкретизация настройки

Настраиваемую подпрограммы или пакеты нельзя использовать напрямую. Сначала они должны быть конкретезированы, что мы делаем с помощью ключевого слова new, как показано в следующем примере:

set.ads

1generic

2   type T is private;

3   X : in out T;

4   --  X can be used in the Set procedure

5procedure Set (E : T);

set.adb

1procedure Set (E : T) is

2begin

3   X := E;

4end Set;

show_generic_instantiation.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Set;

3

4procedure Show_Generic_Instantiation is

5

6   Main    : Integer := 0;

7   Current : Integer;

8

9   procedure Set_Main is new Set (T => Integer,

10                                  X => Main);

11   --  Here, we map the formal parameters to

12   --  actual types and objects.

13   --

14   --  The same approach can be used to

15   --  instantiate functions or packages, e.g.:

16   --

17   --  function Get_Main is new ...

18   --  package Integer_Queue is new ...

19

20begin

21   Current := 10;

22

23   Set_Main (Current);

24   Put_Line ("Value of Main is "

25             & Integer'Image (Main));

26end Show_Generic_Instantiation;

Runtime output

Value of Main is  10

В приведенном выше примере мы создаем экземпляр настраиваемой процедуры Set, сопоставляя формальные параметры T и X с фактическими, уже существующими, элементами, в данном случае типом Integer и переменной Main.

Настраиваемые пакеты

Предыдущие примеры мы сосредочились на настраиваемых подпрограммах. В этом разделе мы рассмотрим настраиваемые пакеты. Их синтаксис аналогичен: мы начинаем с ключевого слова generic, а далее следуют формальныме объявления. Единственное отличие состоит в том, что вместо ключевого слова подпрограммы указывается package.

Вот пример:

element.ads

1generic

2   type T is private;

3package Element is

4

5   procedure Set (E : T);

6   procedure Reset;

7   function Get return T;

8   function Is_Valid return Boolean;

9

10   Invalid_Element : exception;

11

12private

13   Value : T;

14   Valid : Boolean := False;

15end Element;

element.adb

1package body Element is

2

3   procedure Set (E : T) is

4   begin

5      Value := E;

6      Valid := True;

7   end Set;

8

9   procedure Reset is

10   begin

11      Valid := False;

12   end Reset;

13

14   function Get return T is

15   begin

16      if not Valid then

17         raise Invalid_Element;

18      end if;

19      return Value;

20   end Get;

21

22   function Is_Valid return Boolean is (Valid);

23end Element;

show_generic_package.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Element;

3

4procedure Show_Generic_Package is

5

6   package I is new Element (T => Integer);

7

8   procedure Display_Initialized is

9   begin

10      if I.Is_Valid then

11         Put_Line ("Value is initialized");

12      else

13         Put_Line ("Value is not initialized");

14      end if;

15   end Display_Initialized;

16

17begin

18   Display_Initialized;

19

20   Put_Line ("Initializing...");

21   I.Set (5);

22   Display_Initialized;

23   Put_Line ("Value is now set to "

24             & Integer'Image (I.Get));

25

26   Put_Line ("Reseting...");

27   I.Reset;

28   Display_Initialized;

29

30end Show_Generic_Package;

Runtime output

Value is not initialized

Initializing...

Value is initialized

Value is now set to  5

Reseting...

Value is not initialized

В приведенном выше примере мы создали простой контейнер с именем Element, содержащий всего один элемент. Этот контейнер отслеживает, был ли элемент инициализирован или нет.

После написания определения пакета мы создаем экземпляр I пакета Element. Мы используем экземпляр, вызывая подпрограммы пакета (Set, Reset и Get).

Формальные подпрограммы

В дополнение к формальным типам и объектам мы также можем объявлять формальные подпрограммы или пакеты. Этот курс описывает только формальные подпрограммы; формальные пакеты обсуждаются в продвинутом курсе.

Мы используем ключевое слово with для объявления формальной подпрограммы. В приведенном ниже примере мы объявляем формальную функцию (Comparison), которая будет использоваться настраиваемой процедурой Check.

check.ads

1generic

2   Description : String;

3   type T is private;

4   with function Comparison (X, Y : T) return Boolean;

5procedure Check (X, Y : T);

check.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Check (X, Y : T) is

4   Result : Boolean;

5begin

6   Result := Comparison (X, Y);

7   if Result then

8      Put_Line ("Comparison ("

9                & Description

10                & ") between arguments is OK!");

11   else

12      Put_Line ("Comparison ("

13                & Description

14                & ") between arguments is not OK!");

15   end if;

16end Check;

show_formal_subprogram.adb

1with Check;

2

3procedure Show_Formal_Subprogram is

4

5   A, B : Integer;

6

7   procedure Check_Is_Equal is new

8     Check (Description => "equality",

9            T           => Integer,

10            Comparison  => Standard."=");

11   --  Here, we are mapping the standard

12   --  equality operator for Integer types to

13   --  the Comparison formal function

14begin

15   A := 0;

16   B := 1;

17   Check_Is_Equal (A, B);

18end Show_Formal_Subprogram;

Runtime output

Comparison (equality) between arguments is not OK!

Пример: конкретизация ввода/вывода

Ада предлагает настраиваемые пакеты ввода-вывода, которые могут быть конкретизированы для стандартных и произвольных типов. Одним из примеров является настраиваемый пакет Float_IO, который предоставляет такие процедуры, как Put и Get. Фактически, Float_Text_IO - доступный в стандартной библиотеке - является конкретизацией пакета Float_IO и определяется как:

with Ada.Text_IO;

package Ada.Float_Text_IO is new Ada.Text_IO.Float_IO (Float);

Его можно использовать непосредственно с любым объектом типа Float. Например:

show_float_text_io.adb

1with Ada.Float_Text_IO;

2

3procedure Show_Float_Text_IO is

4   X : constant Float := 2.5;

5

6   use Ada.Float_Text_IO;

7begin

8   Put (X);

9end Show_Float_Text_IO;

Runtime output

2.50000E+00

Создание экземпляров настраиваемых пакетов ввода-вывода может быть полезно для пользовательских типов. Например, давайте создадим новый тип Price, который должен отображаться с двумя десятичными цифрами после точки и без экспоненты.

show_float_io_inst.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Float_IO_Inst is

4

5   type Price is digits 3;

6

7   package Price_IO is new

8     Ada.Text_IO.Float_IO (Price);

9

10   P : Price;

11begin

12   --  Set to zero => don't display exponent

13   Price_IO.Default_Exp  := 0;

14

15   P := 2.5;

16   Price_IO.Put (P);

17   New_Line;

18

19   P := 5.75;

20   Price_IO.Put (P);

21   New_Line;

22end Show_Float_IO_Inst;

Runtime output

2.50

5.75

Регулируя значение Default_Exp экземпляра Price_IO для удаления экспоненты, мы можем контролировать, как отображаются переменные типа Price. В качестве примечания мы также могли бы написать:

-- [...]

type Price is new Float;

package Price_IO is new

Ada.Text_IO.Float_IO (Price);

begin

Price_IO.Default_Aft  := 2;

Price_IO.Default_Exp  := 0;

В этом случае мы также изменяем Default_Aft чтобы при вызове Put получить две десятичные цифры после запятой.

В дополнение к настраиваемому пакету Float_IO в Ada.Text_IO доступны следующие настраиваемые пакеты:

- Enumeration_IO для перечислимых типов;

- Integer_IO для целочисленных типов;

- Modular_IO для модульных типов;

- Fixed_IO для типов с фиксированной запятой;

- Decimal_IO для десятичных типов.

Фактически, мы могли бы переписать пример выше, используя десятичные типы:

show_decimal_io_inst.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Decimal_IO_Inst is

4

5   type Price is delta 10.0 ** (-2) digits 12;

6

7   package Price_IO is new

8     Ada.Text_IO.Decimal_IO (Price);

9

10   P : Price;

11begin

12   Price_IO.Default_Exp  := 0;

13

14   P := 2.5;

15   Price_IO.Put (P);

16   New_Line;

17

18   P := 5.75;

19   Price_IO.Put (P);

20   New_Line;

21end Show_Decimal_IO_Inst;

Runtime output

2.50

5.75

Пример: АТД

Важным применением настраиваемых модулей является моделирование абстрактных типов данных (АТД). Фактически Ада предоставляет библиотеку с многочисленными АТД, использующими настраиваемые модули: Ada.Containers (описаны в разделе контейнеров).

Типичным примером АТД является стек:

stacks.ads

1generic

2   Max : Positive;

3   type T is private;

4package Stacks is

5

6   type Stack is limited private;

7

8   Stack_Underflow, Stack_Overflow : exception;

9

10   function Is_Empty (S : Stack) return Boolean;

11

12   function Pop (S : in out Stack) return T;

13

14   procedure Push (S : in out Stack;

15                   V :        T);

16

17private

18

19   type Stack_Array is

20     array (Natural range <>) of T;

21

22   Min : constant := 1;

23

24   type Stack is record

25      Container : Stack_Array (Min .. Max);

26      Top       : Natural := Min - 1;

27   end record;

28

29end Stacks;

stacks.adb

1package body Stacks is

2

3   function Is_Empty (S : Stack) return Boolean is

4     (S.Top < S.Container'First);

5

6   function Is_Full (S : Stack) return Boolean is

7     (S.Top >= S.Container'Last);

8

9   function Pop (S : in out Stack) return T is

10   begin

11      if Is_Empty (S) then

12         raise Stack_Underflow;

13      else

14         return X : T do

15            X     := S.Container (S.Top);

16            S.Top := S.Top - 1;

17         end return;

18      end if;

19   end Pop;

20

21   procedure Push (S : in out Stack;

22                   V :        T) is

23   begin

24      if Is_Full (S) then

25         raise Stack_Overflow;

26      else

27         S.Top               := S.Top + 1;

28         S.Container (S.Top) := V;

29      end if;

30   end Push;

31

32end Stacks;

show_stack.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Stacks;

3

4procedure Show_Stack is

5

6   package Integer_Stacks is new

7     Stacks (Max => 10,

8             T   => Integer);

9   use Integer_Stacks;

10

11   Values : Integer_Stacks.Stack;

12

13begin

14   Push (Values, 10);

15   Push (Values, 20);

16

17   Put_Line ("Last value was "

18             & Integer'Image (Pop (Values)));

19end Show_Stack;

Runtime output

Last value was  20

В этом примере сначала создается настраиваемый пакет стека (Stacks), а затем он конкретизируется чтобы создаеть стек содержащи до 10 целых значений.

Пример: Обмен

Давайте рассмотрим простую процедуру, которая меняет местами переменные типа Color:

colors.ads

1package Colors is

2   type Color is (Black, Red, Green,

3                  Blue, White);

4

5   procedure Swap_Colors (X, Y : in out Color);

6end Colors;

colors.adb

1package body Colors is

2

3   procedure Swap_Colors (X, Y : in out Color) is

4      Tmp : constant Color := X;

5   begin

6      X := Y;

7      Y := Tmp;

8   end Swap_Colors;

9

10end Colors;

test_non_generic_swap_colors.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Colors;      use Colors;

3

4procedure Test_Non_Generic_Swap_Colors is

5   A, B, C : Color;

6begin

7   A := Blue;

8   B := White;

9   C := Red;

10

11   Put_Line ("Value of A is "

12             & Color'Image (A));

13   Put_Line ("Value of B is "

14             & Color'Image (B));

15   Put_Line ("Value of C is "

16             & Color'Image (C));

17

18   New_Line;

19   Put_Line ("Swapping A and C...");

20   New_Line;

21   Swap_Colors (A, C);

22

23   Put_Line ("Value of A is "

24             & Color'Image (A));

25   Put_Line ("Value of B is "

26             & Color'Image (B));

27   Put_Line ("Value of C is "

28             & Color'Image (C));

29end Test_Non_Generic_Swap_Colors;

Runtime output

Value of A is BLUE

Value of B is WHITE

Value of C is RED

Swapping A and C...

Value of A is RED

Value of B is WHITE

Value of C is BLUE

В этом примере Swap_Colors можно использовать только для типа Color. Однако этот алгоритм теоретически можно использовать для любого типа, будь то перечислимый тип или составной тип записи с множеством элементов. Сам алгоритм такой же: отличается только тип. Если, например, мы хотим поменять местами переменные типа Integer, мы не хотим дублировать реализацию. Следовательно, такой алгоритм - идеальный кандидат для абстракции с использованием настраиваемых модулей.

В приведенном ниже примере мы создадим настраиваемую версию Swap_Colors и назовем ее Generic_Swap. Эта настраиваемая версия может работать с любым типом благодаря объявлению формального типа T.

generic_swap.ads

1generic

2   type T is private;

3procedure Generic_Swap (X, Y : in out T);

generic_swap.adb

1procedure Generic_Swap (X, Y : in out T) is

2   Tmp : constant T := X;

3begin

4   X := Y;

5   Y := Tmp;

6end Generic_Swap;

colors.ads

1with Generic_Swap;

2

3package Colors is

4

5   type Color is (Black, Red, Green,

6                  Blue, White);

7

8   procedure Swap_Colors is new

9     Generic_Swap (T => Color);

10

11end Colors;

test_swap_colors.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Colors;       use Colors;

3

4procedure Test_Swap_Colors is

5   A, B, C : Color;

6begin

7   A := Blue;

8   B := White;

9   C := Red;

10

11   Put_Line ("Value of A is "

12             & Color'Image (A));

13   Put_Line ("Value of B is "

14             & Color'Image (B));

15   Put_Line ("Value of C is "

16             & Color'Image (C));

17

18   New_Line;

19   Put_Line ("Swapping A and C...");

20   New_Line;

21   Swap_Colors (A, C);

22

23   Put_Line ("Value of A is "

24             & Color'Image (A));

25   Put_Line ("Value of B is "

26             & Color'Image (B));

27   Put_Line ("Value of C is "

28             & Color'Image (C));

29end Test_Swap_Colors;

Runtime output

Value of A is BLUE

Value of B is WHITE

Value of C is RED

Swapping A and C...

Value of A is RED

Value of B is WHITE

Value of C is BLUE

Как мы видим в примере, мы можем создать ту же процедуру Swap_Colors, что и в первой версии алгоритма, объявив ее как конкретизацию настраиваемой процедуры Generic_Swap. Мы сопоставляем формальный тип T с типом Color, указывая его в качестве аргумента конкретизации Generic_Swap.

Пример: Обратный порядок элементов

Предыдущий пример с алгоритмом обмена двух значений является одним из простейших примеров использования настраиваемых модулей. Теперь мы изучим алгоритм обращения элементов массива. Во-первых, давайте начнем с версии алгоритма без использования настраиваемых модулей, разработав версию конкретно для типа Color:

colors.ads

1package Colors is

2

3   type Color is (Black, Red, Green,

4                  Blue, White);

5

6   type Color_Array is

7     array (Integer range <>) of Color;

8

9   procedure Reverse_It (X : in out Color_Array);

10

11end Colors;

colors.adb

1package body Colors is

2

3   procedure Reverse_It (X : in out Color_Array) is

4   begin

5      for I in X'First ..

6               (X'Last + X'First) / 2 loop

7         declare

8            Tmp     : Color;

9            X_Left  : Color

10              renames X (I);

11            X_Right : Color

12              renames X (X'Last + X'First - I);

13         begin

14            Tmp     := X_Left;

15            X_Left  := X_Right;

16            X_Right := Tmp;

17         end;

18      end loop;

19   end Reverse_It;

20

21end Colors;

test_non_generic_reverse_colors.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Colors;      use Colors;

3

4procedure Test_Non_Generic_Reverse_Colors is

5

6   My_Colors : Color_Array (1 .. 5) :=

7     (Black, Red, Green, Blue, White);

8

9begin

10   for C of My_Colors loop

11      Put_Line ("My_Color: " & Color'Image (C));

12   end loop;

13

14   New_Line;

15   Put_Line ("Reversing My_Color...");

16   New_Line;

17   Reverse_It (My_Colors);

18

19   for C of My_Colors loop

20      Put_Line ("My_Color: " & Color'Image (C));

21   end loop;

22

23end Test_Non_Generic_Reverse_Colors;

Runtime output

My_Color: BLACK

My_Color: RED

My_Color: GREEN

My_Color: BLUE

My_Color: WHITE

Reversing My_Color...

My_Color: WHITE

My_Color: BLUE

My_Color: GREEN

My_Color: RED

My_Color: BLACK

Процедура Reverse_It принимает массив цветов, начинает с обмена первого и последнего элементов массива и продолжает делать это со следующими элементами последовательно, пока не достигнет середины массива. В этот момент весь массив будет перевернут, как мы видим из выходных данных тестовой программы.

Чтобы абстрагироваться от этой процедуры, мы объявляем формальные типы для трех элементов алгоритма:

- тип компоненты массива (в примере - тип Color)

- диапазон, используемый для массива (в примере - целочисленный диапазон)

- фактический тип массива (в примере - тип Color_Array)

Это настраиваемая версия алгоритма:

generic_reverse.ads

1generic

2   type T is private;

3   type Index is range <>;

4   type Array_T is

5     array (Index range <>) of T;

6procedure Generic_Reverse (X : in out Array_T);

generic_reverse.adb

1procedure Generic_Reverse (X : in out Array_T) is

2begin

3   for I in X'First ..

4            (X'Last + X'First) / 2 loop

5      declare

6         Tmp     : T;

7         X_Left  : T

8           renames X (I);

9         X_Right : T

10           renames X (X'Last + X'First - I);

11      begin

12         Tmp     := X_Left;

13         X_Left  := X_Right;

14         X_Right := Tmp;

15      end;

16   end loop;

17end Generic_Reverse;

colors.ads

1with Generic_Reverse;

2

3package Colors is

4

5   type Color is (Black, Red, Green,

6                  Blue, White);

7

8   type Color_Array is

9     array (Integer range <>) of Color;

10

11   procedure Reverse_It is new

12     Generic_Reverse (T       => Color,

13                      Index   => Integer,

14                      Array_T => Color_Array);

15

16end Colors;

test_reverse_colors.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Colors;      use Colors;

3

4procedure Test_Reverse_Colors is

5

6   My_Colors : Color_Array (1 .. 5) :=

7     (Black, Red, Green, Blue, White);

8

9begin

10   for C of My_Colors loop

11      Put_Line ("My_Color: "

12                & Color'Image (C));

13   end loop;

14

15   New_Line;

16   Put_Line ("Reversing My_Color...");

17   New_Line;

18   Reverse_It (My_Colors);

19

20   for C of My_Colors loop

21      Put_Line ("My_Color: "

22                & Color'Image (C));

23   end loop;

24

25end Test_Reverse_Colors;

Runtime output

My_Color: BLACK

My_Color: RED

My_Color: GREEN

My_Color: BLUE

My_Color: WHITE

Reversing My_Color...

My_Color: WHITE

My_Color: BLUE

My_Color: GREEN

My_Color: RED

My_Color: BLACK

Как упоминалось выше, мы выделили три параметра алгоритма:

- тип T абстрагирует элементы массива

- тип Index абстрагирует диапазон, используемый для массива

- тип Array_T абстрагирует тип массива и использует формальные объявления типов T и Index.

Пример: Тестовое приложение

В предыдущем примере мы сосредоточились только на абстрагировании самого алгоритма обращения массива. Однако мы могли бы аналогично абстрагировать наше небольшого тестового приложения. Это может быть полезно, если мы, например, решим протестировать другие процедуры, меняющие элементы массива.

Чтобы сделать это, мы снова должны выбрать элементы для абстрагирования. Поэтому мы объевляем следующие формальные параметры:

- S: строка, содержащая имя массива

- функция Image, преобразующая элемент типа T в строку

- процедура Test, которая выполняет некоторую операцию с массивом

Обратите внимание, что Image и Test являются примерами формальных подпрограмм, а S - примером формального объекта.

Вот версия тестового приложения, использующего общую процедуру Perform_Test:

generic_reverse.ads

1generic

2   type T is private;

3   type Index is range <>;

4   type Array_T is

5     array (Index range <>) of T;

6procedure Generic_Reverse (X : in out Array_T);

generic_reverse.adb

1procedure Generic_Reverse (X : in out Array_T) is

2begin

3   for I in X'First ..

4            (X'Last + X'First) / 2 loop

5      declare

6         Tmp     : T;

7         X_Left  : T

8           renames X (I);

9         X_Right : T

10           renames X (X'Last + X'First - I);

11      begin

12         Tmp     := X_Left;

13         X_Left  := X_Right;

14         X_Right := Tmp;

15      end;

16   end loop;

17end Generic_Reverse;

perform_test.ads

1generic

2   type T is private;

3   type Index is range <>;

4   type Array_T is

5     array (Index range <>) of T;

6   S : String;

7   with function Image (E : T) return String is <>;

8   with procedure Test (X : in out Array_T);

9procedure Perform_Test (X : in out Array_T);

perform_test.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2

3procedure Perform_Test (X : in out Array_T) is

4begin

5   for C of X loop

6      Put_Line (S & ": " & Image (C));

7   end loop;

8

9   New_Line;

10   Put_Line ("Testing " & S & "...");

11   New_Line;

12   Test (X);

13

14   for C of X loop

15      Put_Line (S & ": " & Image (C));

16   end loop;

17end Perform_Test;

colors.ads

1with Generic_Reverse;

2

3package Colors is

4

5   type Color is (Black, Red, Green,

6                  Blue, White);

7

8   type Color_Array is

9     array (Integer range <>) of Color;

10

11   procedure Reverse_It is new

12     Generic_Reverse (T       => Color,

13                      Index   => Integer,

14                      Array_T => Color_Array);

15

16end Colors;

test_reverse_colors.adb

1with Colors;       use Colors;

2with Perform_Test;

3

4procedure Test_Reverse_Colors is

5

6   procedure Perform_Test_Reverse_It is new

7     Perform_Test (T       => Color,

8                   Index   => Integer,

9                   Array_T => Color_Array,

10                   S       => "My_Color",

11                   Image   => Color'Image,

12                   Test    => Reverse_It);

13

14   My_Colors : Color_Array (1 .. 5) :=

15     (Black, Red, Green, Blue, White);

16

17begin

18   Perform_Test_Reverse_It (My_Colors);

19end Test_Reverse_Colors;

Runtime output

My_Color: BLACK

My_Color: RED

My_Color: GREEN

My_Color: BLUE

My_Color: WHITE

Testing My_Color...

My_Color: WHITE

My_Color: BLUE

My_Color: GREEN

My_Color: RED

My_Color: BLACK

В этом примере создается процедура, Perform_Test_Reverse_It как экземпляр настраиваемой процедуры (Perform_Test). Обратите внимание, что:

- Для формальной функции Image мы используем атрибут 'Image типа Color

- Для формальной процедуры тестирования Test мы ссылаемся на процедуру Reverse_Array из пакета.

Footnotes

Исключения

Ада использует исключения для обработки ошибок. В отличие от многих других языков, в Аде принято говорить о возбуждении, а не о выбрасывании исключений и их обработке, а не перехвате.

Объявление исключения

Исключения в Аде - это не типы, а объекты, что может показаться вам необычным, если вы привыкли к тому, как работают исключения в Java или Python. Вот как вы объявляете исключение:

exceptions.ads

1package Exceptions is

2    My_Except : exception;

3    --  Like an object. *NOT* a type !

4end Exceptions;

Несмотря на то, что они являются объектами, каждый объявленный объект исключения вы используете как «класс» или «семейство» исключений. Ада не требует, чтобы подпрограмма при объявлении указывала каждое исключение, которое может быть возбуждено.

Возбуждение исключения

Чтобы возбудить исключение нашего только что объявленного класса исключения, сделайте следующее:

main.adb

1with Exceptions; use Exceptions;

2

3procedure Main is

4begin

5   raise My_Except;

6   --  Execution of current control flow

7   --  abandoned; an exception of kind

8   --  "My_Except" will bubble up until it

9   --  is caught.

10

11   raise My_Except with "My exception message";

12   --  Execution of current control flow

13   --  abandoned; an exception of kind

14   --  "My_Except" with associated string will

15   --  bubble up until it is caught.

16end Main;

Build output

main.adb:11:04: warning: unreachable code [enabled by default]

Runtime output

raised EXCEPTIONS.MY_EXCEPT : main.adb:5

Обработка исключения

Далее мы рассмотрим, как обрабатывать исключения, которые были возбуждены нами или библиотеками, которые мы вызываем. Изящная вещь в Аде заключается в том, что вы можете добавить обработчик исключений в любой блок операторов следующим образом:

open_file.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Exceptions;  use Ada.Exceptions;

3

4procedure Open_File is

5   File : File_Type;

6begin

7   --  Block (sequence of statements)

8   begin

9      Open (File, In_File, "input.txt");

10   exception

11      when E : Name_Error =>

12      --       ^ Exception to be handled

13         Put ("Cannot open input file : ");

14         Put_Line (Exception_Message (E));

15         raise;

16         --  Reraise current occurence

17   end;

18end Open_File;

Runtime output

Cannot open input file : input.txt: No such file or directory

raised ADA.IO_EXCEPTIONS.NAME_ERROR : input.txt: No such file or directory

В приведенном выше примере мы используем функцию Exception_Message из пакета Ada.Exceptions. Эта функция возвращает сообщение, связанное с исключением, в виде строки.

Вам не нужно вводить новый блок только чтобы обработать исключения: вы можете добавить его в блок операторов вашей текущей подпрограммы:

open_file.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Exceptions;  use Ada.Exceptions;

3

4procedure Open_File is

5   File : File_Type;

6begin

7   Open (File, In_File, "input.txt");

8--  Exception block can be added to any block

9exception

10   when Name_Error =>

11      Put ("Cannot open input file");

12end Open_File;

Build output

open_file.adb:2:09: warning: no entities of "Ada.Exceptions" are referenced [-gnatwu]

open_file.adb:2:23: warning: use clause for package "Exceptions" has no effect [-gnatwu]

Runtime output

Cannot open input file

Обратите внимание

Обработчики исключений имеют важное ограничение, с которым вам нужно быть осторожным: исключения, созданные в разделе описаний, не перехватываются обработчиками этого блока. Так, например, в следующем коде исключение не будет поймано.

be_careful.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Ada.Exceptions;  use Ada.Exceptions;

3

4procedure Be_Careful is

5   function Dangerous return Integer is

6   begin

7      raise Constraint_Error;

8      return 42;

9   end Dangerous;

10

11begin

12   declare

13      A : Integer := Dangerous;

14   begin

15      Put_Line (Integer'Image (A));

16   exception

17      when Constraint_Error =>

18         Put_Line ("error!");

19   end;

20end Be_Careful;

Build output

be_careful.adb:2:09: warning: no entities of "Ada.Exceptions" are referenced [-gnatwu]

be_careful.adb:2:23: warning: use clause for package "Exceptions" has no effect [-gnatwu]

be_careful.adb:13:07: warning: "A" is not modified, could be declared constant [-gnatwk]

Runtime output

raised CONSTRAINT_ERROR : be_careful.adb:7 explicit raise

Это также относится к блоку исключений верхнего уровня, который является частью текущей подпрограммы.

Предопределенные исключения

Ада имеет очень небольшое количество предопределенных исключений:

- Constraint_Error является основным, с которым вы можете столкнуться. Возбуждение исключения Constraint_Error происходит:

- Когда происходит выход за границы массива или, в общем, любое нарушение ограничений

- В случае переполнения

- В случае обращения по пустой ссылке

- В случае деления на 0

- Program_Error тоже может встетиться, но, вероятно, реже. Возбуждение исключения возникает в более сложных ситуациях, таких как проблемы с порядком предвыполнения и некоторые случаи обнаружения ошибочного выполнения.

- Storage_Error произойдет из-за проблем с памятью, таких как:

- Недостаточно памяти (при распределении)

- Недостаточно стека

- Tasking_Error сигнализирует об ошибках, связанных с задачами, такими как любая ошибка, возникающая во время активации задачи.

Не следует повторно использовать предопределенные исключения. Если вы будете так делать, то при возбужденнии одного из них не будет ясно, связано ли оно с работой встроенной языковой операции или нет.

Footnotes

Управление задачами

Задачи и защищенные объекты позволяют реализовать параллельное исполнение в Аде. В следующих разделах эти концепции объясняются более подробно.

Задачи

Задачу можно рассматривать как приложение, которое выполняется одновременно с основным приложением. В других языках программирования задачи могут назваться потоками#1, а управление задачами можно назвать многопоточностью#2.

Задачи могут синхронизироваться с основным приложением, но также могут обрабатывать информацию полностью независимо от основного приложения. Здесь мы покажем, как это достигается.

Простая задача

Задачи объявляются с использованием ключевого слова task. Реализация задачи определяется в теле задачи (task body). Например:

show_simple_task.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Task is

4   task T;

5

6   task body T is

7   begin

8      Put_Line ("In task T");

9   end T;

10begin

11   Put_Line ("In main");

12end Show_Simple_Task;

Runtime output

In main

In task T

Здесь мы объявляем и реализуем задачу T. Как только запускается основное приложение, задача T запускается автоматически - нет необходимости вручную запускать эту задачу. Запустив приложение выше, мы видим, что выполняются оба вызова Put_Line.

Обратите внимание, что:

- Основное приложение само по себе является задачей (основной задачей).

- В этом примере подпрограмма Show_Simple_Task является основной задачей приложения.

- Задача T - это подзадача.

- Каждая подзадача имеет задачу-родителя.

- Поэтому основная задача - это также задача-родитель задачи T.

- Количество задач не ограничено одной: мы могли бы включить задачу T2 в приведенный выше пример.

- Эта задача также запускается автоматически и выполняется одновременно как с задачей T, так и с основной задачей. Например:

show_simple_tasks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3      procedure Show_Simple_Tasks is

4         task T;

5         task T2;

6

7         task body T is

8         begin

9            Put_Line ("In task T");

10         end T;

11

12         task body T2 is

13         begin

14            Put_Line ("In task T2");

15         end T2;

16

17      begin

18         Put_Line ("In main");

19      end Show_Simple_Tasks;

Runtime output

In task T

In main

In task T2

Простая синхронизация

Как мы сейчас видели, как только запускается основная задача, автоматически запускаются и ее подзадачи. Основная задача продолжает свою работу до тех пор, пока ей есть что делать. Однако после этого она не сразу завершится. Вместо этого задача ожидает завершения выполнения своих подзадач, прежде чем позволит себе завершиться. Другими словами, этот процесс ожидания обеспечивает синхронизацию между основной задачей и ее подзадачами. После этой синхронизации основная задача завершится. Например:

show_simple_sync.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Sync is

4   task T;

5   task body T is

6   begin

7      for I in 1 .. 10 loop

8         Put_Line ("hello");

9      end loop;

10   end T;

11begin

12   null;

13   --  Will wait here until all tasks

14   --  have terminated

15end Show_Simple_Sync;

Runtime output

hello

hello

hello

hello

hello

hello

hello

hello

hello

hello

Тот же механизм используется для других подпрограмм, содержащих подзадачи: задача-родитель подпрограммы будет ждать завершения своих подзадач. Таким образом, этот механизм не ограничивается основным приложением, а также применяется к любой подпрограмме, вызываемой основным приложением или его подпрограммами.

Синхронизация также происходит, если мы вынесем задачу в отдельный пакет. В приведенном ниже примере мы объявляем задачу T в пакете Simple_Sync_Pkg.

simple_sync_pkg.ads

1package Simple_Sync_Pkg is

2   task T;

3end Simple_Sync_Pkg;

Это соответствующее тело пакета:

simple_sync_pkg.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Simple_Sync_Pkg is

4   task body T is

5   begin

6      for I in 1 .. 10 loop

7         Put_Line ("hello");

8      end loop;

9   end T;

10end Simple_Sync_Pkg;

Поскольку пакет указан в with основной процедуры, задача T, определенная в пакете, является частью основной задачи. Например:

test_simple_sync_pkg.adb

1with Simple_Sync_Pkg;

2

3procedure Test_Simple_Sync_Pkg is

4begin

5   null;

6   --  Will wait here until all tasks

7   --  have terminated

8end Test_Simple_Sync_Pkg;

Build output

test_simple_sync_pkg.adb:1:06: warning: unit "Simple_Sync_Pkg" is not referenced [-gnatwu]

Runtime output

hello

hello

hello

hello

hello

hello

hello

hello

hello

hello

Опять же, как только основная задача достигает своего конца, она синхронизируется с задачей T из Simple_Sync_Pkg перед завершением.

Оператор задержки

Мы можем ввести задержку, используя ключевое слово delay. Это переводит задачу в спящий режим на время, указанное (в секундах) в операторе delay. Например:

show_delay.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Delay is

4

5   task T;

6

7   task body T is

8   begin

9      for I in 1 .. 5 loop

10         Put_Line ("hello from task T");

11         delay 1.0;

12         --    ^ Wait 1.0 seconds

13      end loop;

14   end T;

15begin

16   delay 1.5;

17   Put_Line ("hello from main");

18end Show_Delay;

Runtime output

hello from task T

hello from task T

hello from main

hello from task T

hello from task T

hello from task T

В этом примере мы заставляем задачу T ждать одну секунду после каждого вывода сообщения "hello". Кроме того, основная задача ожидает 1,5 секунды перед выводом своего сообщения "hello".

Синхронизация: рандеву

Единственный тип синхронизации, который мы видели до сих пор, - это тот, что происходит автоматически в конце основной задачи. Вы также можете определить пользовательские точки синхронизации (входы задач), используя ключевое слово entry. Вход задачи можно рассматривать как особый вид подпрограммы, вызов которой выполняется другой задачей и имеет синтаксис аналогичный синтаксу вызова процедуры.

При написании тела задачи вы определяете места, где задача будет принимать входы, используя ключевое слово accept. Задача выполняется до тех пор, пока не достигнет оператора accept, а затем ожидает синхронизации с вызывающей задачей. А именно:

- вызываемая задача ожидает в этот момент (в операторе принятия accept) и готова принять вызов соответствующей входа из вызывающей задачи;

- вызывающая задача вызывает вход задачи способом, аналогичным вызову процедуры, чтобы синхронизации с вызываемой задачей.

Эта синхронизация между задачами называется рандеву. Давайте посмотрим на пример:

show_rendezvous.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Rendezvous is

4

5   task T is

6      entry Start;

7   end T;

8

9   task body T is

10   begin

11      accept Start;

12      --     ^ Waiting for somebody

13      --       to call the entry

14

15      Put_Line ("In T");

16   end T;

17

18begin

19   Put_Line ("In Main");

20

21   --  Calling T's entry:

22   T.Start;

23end Show_Rendezvous;

Runtime output

In Main

In T

В этом примере мы объявляем вход Start задачи T. В теле задачи мы реализуем этот вход с помощью оператора принятия accept Start. Когда задача T достигает этой точки, она ожидает основную задачу. Эта синхронизация происходит в операторе T.Start. После завершения синхронизации основная задача и задача T снова выполняются одновременно, пока они не синхронизируются в последний раз, когда основная задача завершается.

Вход может использоваться для выполнения чего-то большего, чем простая синхронизация задач: он также может выполнять несколько операторов в течение времени синхронизации обеих задач. Мы делаем это с помощью блока do ... end. Для предыдущего примера мы бы просто написали accept Start do <операторы>; end;. Мы используем эту конструкцию в следующем примере.

Обрабатывающий цикл

Задача может исполнять оператор принятия входа не ограниченое число раз. Мы могли бы даже создать бесконечный цикл в задаче и принимать вызовы одного и того же входа снова и снова. Однако бесконечный цикл препятствует завершению задачи-родителя и заблокирует ее, когда она достигает своего конца. Поэтому цикл, содержащий оператор принятия accept в теле задачи, обычно используется в сочетании с оператором select ... or terminate (выбрать или завершить). Говоря упрощенно, этот оператор позволяет родительской задаче автоматически завершать выполнение подзадачи по достижении своего конца. Например:

show_rendezvous_loop.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Rendezvous_Loop is

4

5   task T is

6      entry Reset;

7      entry Increment;

8   end T;

9

10   task body T is

11      Cnt : Integer := 0;

12   begin

13      loop

14         select

15            accept Reset do

16               Cnt := 0;

17            end Reset;

18            Put_Line ("Reset");

19         or

20            accept Increment do

21               Cnt := Cnt + 1;

22            end Increment;

23            Put_Line ("In T's loop ("

24                      & Integer'Image (Cnt)

25                      & ")");

26         or

27            terminate;

28         end select;

29      end loop;

30   end T;

31

32begin

33   Put_Line ("In Main");

34

35   for I in 1 .. 4 loop

36      --  Calling T's entry multiple times

37      T.Increment;

38   end loop;

39

40   T.Reset;

41   for I in 1 .. 4 loop

42      --  Calling T's entry multiple times

43      T.Increment;

44   end loop;

45

46end Show_Rendezvous_Loop;

Runtime output

In Main

In T's loop ( 1)

In T's loop ( 2)

In T's loop ( 3)

In T's loop ( 4)

Reset

In T's loop ( 1)

In T's loop ( 2)

In T's loop ( 3)

In T's loop ( 4)

В этом примере тело задачи содержит бесконечный цикл, который принимает вызовы входов Reset и Increment. Нам стоит отметить следуещее:

- Блок accept E do ... end используется для увеличения счетчика.

- До тех пор, пока задача T выполняет блок do ... end, основная задача ожидает завершения блока.

- Основная задача выполняет вызов входа Increment несколько раз в цикле от 1 .. 4. Она также вызывает вход Reset перед вторым циклом.

- Поскольку задача T содержит бесконечный цикл, она всегда принимает вызовы входов Reset и Increment.

- Когда основная задача достигает конца, она проверяет статус задачи T. Несмотря на то, что задача T может принимать новые вызовы входов Reset или Increment, главная задача может завершить задачу T введу наличия or terminate ветви оператора select.

Циклические задачи

В предыдущем примере мы видели, как приостановить задачу на указанное время с помощью ключевого слова delay. Однако использования операторов задержки в цикле недостаточно, чтобы гарантировать регулярные интервалы между итерациями цикла. Допустим вызовы процедуры выполняющей интенсивные вычисления чередуется выполнением операторов задержки:

while True loop

delay 1.0;

--    ^ Wait 1.0 seconds

Computational_Intensive_App;

end loop;

В этом случае мы не можем гарантировать, что после 10 выполнений оператора delay прошло ровно 10 секунд, поскольку процедура Computational_Intensive_App может влиять на длительность итерации. Во многих случаях этот дрейф не имеет значения, поэтому достаточно использовать ключевое слово delay.

Однако бывают ситуации, когда такой дрейф недопустим. В этих случаях нам нужно использовать оператор delay until, который принимает точное время окончания задержки, позволяя нам сохранить востоянные интервалы. Это полезно, например, в приложениях реального времени.

Вскоре мы увидим пример того, как можно получить этот временной дрейф и как оператор delay until позволяет обойти проблему. Но прежде чем мы это сделаем, мы рассмотрим пакет, содержащий процедуру, позволяющую нам измерять прошедшее время (Show_Elapsed_Time) и фиктивную процедуру Computational_Intensive_App, которая эмулирыется с помощью простой задержки. Вот полный текст пакета:

delay_aux_pkg.ads

1with Ada.Real_Time; use Ada.Real_Time;

2

3package Delay_Aux_Pkg is

4

5   function Get_Start_Time return Time

6     with Inline;

7

8   procedure Show_Elapsed_Time

9     with Inline;

10

11   procedure Computational_Intensive_App;

12private

13   Start_Time   : Time := Clock;

14

15   function Get_Start_Time return Time is (Start_Time);

16

17end Delay_Aux_Pkg;

delay_aux_pkg.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Delay_Aux_Pkg is

4

5   procedure Show_Elapsed_Time is

6      Now_Time     : Time;

7      Elapsed_Time : Time_Span;

8   begin

9      Now_Time     := Clock;

10      Elapsed_Time := Now_Time - Start_Time;

11      Put_Line ("Elapsed time "

12                & Duration'Image (To_Duration (Elapsed_Time))

13                & " seconds");

14   end Show_Elapsed_Time;

15

16   procedure Computational_Intensive_App is

17   begin

18      delay 0.5;

19   end Computational_Intensive_App;

20

21end Delay_Aux_Pkg;

Используя этот вспомогательный пакет, теперь мы готовы написать наше приложение с дрейфом по времени:

show_time_task.adb

1with Ada.Text_IO;   use Ada.Text_IO;

2with Ada.Real_Time; use Ada.Real_Time;

3

4with Delay_Aux_Pkg;

5

6procedure Show_Time_Task is

7   package Aux renames Delay_Aux_Pkg;

8

9   task T;

10

11   task body T is

12      Cnt   : Integer := 1;

13   begin

14      for I in 1 .. 5 loop

15         delay 1.0;

16

17         Aux.Show_Elapsed_Time;

18         Aux.Computational_Intensive_App;

19

20         Put_Line ("Cycle # "

21                   & Integer'Image (Cnt));

22         Cnt  := Cnt + 1;

23      end loop;

24      Put_Line ("Finished time-drifting loop");

25   end T;

26

27begin

28   null;

29end Show_Time_Task;

Build output

show_time_task.adb:2:09: warning: no entities of "Ada.Real_Time" are referenced [-gnatwu]

show_time_task.adb:2:21: warning: use clause for package "Real_Time" has no effect [-gnatwu]

Runtime output

Elapsed time  1.035948169 seconds

Cycle #  1

Elapsed time  2.545618496 seconds

Cycle #  2

Elapsed time  4.050430835 seconds

Cycle #  3

Elapsed time  5.552350350 seconds

Cycle #  4

Elapsed time  7.082408585 seconds

Cycle #  5

Finished time-drifting loop

Запустив приложение, мы видим, что у нас уже есть разница во времени примерно в четыре секунды после трех итераций цикла из-за дрейфа, вызванного Computational_Intensive_Applications. Однако, используя оператор delay until, мы можем избежать этого дрейфа и получить регулярный интервал ровно итерации в одну секунду:

show_time_task.adb

1with Ada.Text_IO;   use Ada.Text_IO;

2with Ada.Real_Time; use Ada.Real_Time;

3

4with Delay_Aux_Pkg;

5

6procedure Show_Time_Task is

7   package Aux renames Delay_Aux_Pkg;

8

9   task T;

10

11   task body T is

12      Cycle : constant Time_Span :=

13        Milliseconds (1000);

14      Next  : Time := Aux.Get_Start_Time

15                      + Cycle;

16

17      Cnt   : Integer := 1;

18   begin

19      for I in 1 .. 5 loop

20         delay until Next;

21

22         Aux.Show_Elapsed_Time;

23         Aux.Computational_Intensive_App;

24

25         --  Calculate next execution time

26         --  using a cycle of one second

27         Next := Next + Cycle;

28

29         Put_Line ("Cycle # "

30                   & Integer'Image (Cnt));

31         Cnt  := Cnt + 1;

32      end loop;

33      Put_Line ("Finished cycling");

34   end T;

35

36begin

37   null;

38end Show_Time_Task;

Runtime output

Elapsed time  1.004152324 seconds

Cycle #  1

Elapsed time  2.003440248 seconds

Cycle #  2

Elapsed time  3.030813293 seconds

Cycle #  3

Elapsed time  4.001581985 seconds

Cycle #  4

Elapsed time  5.032210132 seconds

Cycle #  5

Finished cycling

Теперь, как мы можем видеть, запустив приложение, оператор delay until гарантирует, что Computational_Intensive_App не нарушает регулярный интервал в одну секунду между итерациями.

Защищенные объекты

Когда несколько задач получают доступ к общим данным, может произойти повреждение этих данных. Например, данные могут оказаться несогласованными, если одна задача перезаписывает части информации, которые в то же время считываются другой задачей. Чтобы избежать подобных проблем и обеспечить скоординированный доступ к информации, мы используем защищенные объекты.

Защищенные объекты инкапсулируют данные и обеспечивают доступ к этим данным с помощью защищенных операций, которые могут быть подпрограммами или защищенными входами. Использование защищенных объектов гарантирует, что данные не будут повреждены из-за «состояния гонки» или другого одновременного доступа.

Важное замечание.

Защищенные объекты могут быть реализованы с помощью задач Ада. Фактически это был единственный возможный способ их реализации в Аде 83 (первый вариант стандарта языка Ада). Однако использование защищённых объектов гораздо проще, чем использование аналогичных механизмов, реализованных с использованием лишь задач. Поэтому предпочтительно использовать защищенные объекты, когда ваша основная цель - только защита данных.

Простой объект

Вы объявляете защищенный объект с помощью ключевого слова protected. Синтаксис аналогичен тому, который используется для пакетов: вы можете объявлять операции (например, процедуры и функции) в видимом разделе, а данные - в личном разделе. Соответствующая реализация операций включена в тело защищенного объекта (protected body). Например:

show_protected_objects.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Protected_Objects is

4

5   protected Obj is

6      --  Operations go here (only subprograms)

7      procedure Set (V : Integer);

8      function Get return Integer;

9   private

10      --  Data goes here

11      Local : Integer := 0;

12   end Obj;

13

14   protected body Obj is

15      --  procedures can modify the data

16      procedure Set (V : Integer) is

17      begin

18         Local := V;

19      end Set;

20

21      --  functions cannot modify the data

22      function Get return Integer is

23      begin

24         return Local;

25      end Get;

26   end Obj;

27

28begin

29   Obj.Set (5);

30   Put_Line ("Number is: "

31             & Integer'Image (Obj.Get));

32end Show_Protected_Objects;

Runtime output

Number is:  5

В этом примере мы определяем две операции для Obj: Set и Get. Реализация этих операций находится в теле объекта Obj. Синтаксис, используемый для записи этих операций, такой же, как и для обычных процедур и функций. Реализация защищенных объектов проста - мы просто читаем и переписываем значение Local в этих подпрограммах. Для вызова этих операций в основном приложении мы используем точечную нотацию, например, Obj.Get.

Входы

В дополнение к защищенным процедурам и функциям вы также можете определить защищенные входы. Сделайте это, используя ключевое слово entry. Защищенные входы позволяют вам определить барьеры с помощью ключевого слова when. Барьеры - это условия, которые должны быть выполнены до того, как вход сможет начать выполнять свой код - мы говорим о снятии барьера при выполнении условия.

В предыдущем примере использовались процедуры и функции для определения операций с защищенными объектами. Однако при этом можно считать защищенную информацию (через Obj.Get) до того, как она будет установлена (через Obj.Set). Чтобы код имел детерминированное поведение, мы указали значение по умолчанию (0). Если, вместо этого, переписать функцию Obj.Get как вход, мы сможем установить барьер, гарантирующий, что ни одна задача не сможет прочитать информацию до того, как она будет записана.

В следующем примере реализован барьер для операции Obj.Get. Он также содержит две параллельно исполняющиеся подпрограммы (основная задача и задача T), которые пытаются получить доступ к защищаемому объекту.

show_protected_objects_entries.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Protected_Objects_Entries is

4

5   protected Obj is

6      procedure Set (V : Integer);

7      entry Get (V : out Integer);

8   private

9      Local  : Integer;

10      Is_Set : Boolean := False;

11   end Obj;

12

13   protected body Obj is

14      procedure Set (V : Integer) is

15      begin

16         Local := V;

17         Is_Set := True;

18      end Set;

19

20      entry Get (V : out Integer)

21        when Is_Set is

22         --  Entry is blocked until the

23         --  condition is true. The barrier

24         --  is evaluated at call of entries

25         --  and at exits of procedures and

26         --  entries. The calling task sleeps

27         --  until the barrier is released.

28      begin

29         V := Local;

30         Is_Set := False;

31      end Get;

32   end Obj;

33

34   N : Integer := 0;

35

36   task T;

37

38   task body T is

39   begin

40      Put_Line ("Task T will delay for 4 seconds...");

41      delay 4.0;

42      Put_Line ("Task T will set Obj...");

43      Obj.Set (5);

44      Put_Line ("Task T has just set Obj...");

45   end T;

46begin

47   Put_Line ("Main application will get Obj...");

48   Obj.Get (N);

49   Put_Line ("Main application has just retrieved Obj...");

50   Put_Line ("Number is: " & Integer'Image (N));

51

52end Show_Protected_Objects_Entries;

Runtime output

Task T will delay for 4 seconds...

Main application will get Obj...

Task T will set Obj...

Task T has just set Obj...

Main application has just retrieved Obj...

Number is:  5

Как видим, запустив пример, основное приложение ждет, пока не произойдет запись в защищенный объект (по вызову Obj.Set в задаче T), прежде чем прочитать информацию (через Obj.Get). Поскольку в задаче T добавлена 4-секундная задержка, основное приложение также задерживается на 4 секунды. Только после этой задержки задача T записывает данные в объект и снимает барьер в Obj.Get, чтобы главное приложение могло затем возобновить обработку (после извлечения информации из защищенного объекта).

Задачные и защищенные типы

В предыдущих примерах мы определили единичные задачи и защищенные объекты. Однако мы можем описывать задачи и защищенные объекты, используя определения типов. Это позволяет нам, например, создавать несколько задач на основе только одного типа задач.

Задачные типы

Задачный типй - это обобщение задачи. Его объявление аналогично единичным задачам: вы заменяете task на task type. Разница между единичными задачами и задачными заключается в том, что задачные типы не создают фактические задачи и не запускают их автоматически. Вместо этого требуется объявление задачи. Именно так работают обычные переменные и типы: объекты создаются только с помощью определений переменных, но не определений типов.

Чтобы проиллюстрировать это, мы повторим наш первый пример:

show_simple_task.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Task is

4   task T;

5

6   task body T is

7   begin

8      Put_Line ("In task T");

9   end T;

10begin

11   Put_Line ("In main");

12end Show_Simple_Task;

Runtime output

In task T

In main

Теперь мы переписываем его, заменив задачу task T задачным типом task type TT. Объявляем задачу (A_Task) на основе задачного типа TT после её определения:

show_simple_task_type.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Task_Type is

4   task type TT;

5

6   task body TT is

7   begin

8      Put_Line ("In task type TT");

9   end TT;

10

11   A_Task : TT;

12begin

13   Put_Line ("In main");

14end Show_Simple_Task_Type;

Runtime output

In task type TT

In main

Мы можем расширить этот пример и создать массив задач. Поскольку мы используем тот же синтаксис, что и для объявлений переменных, мы используем аналогичный синтаксис для задачного типа: array (<>) of Task_Type. Кроме того, мы можем передавать информацию отдельным задачам, определив начальный вход Start. Вот обновленный пример:

show_task_type_array.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Task_Type_Array is

4   task type TT is

5      entry Start (N : Integer);

6   end TT;

7

8   task body TT is

9      Task_N : Integer;

10   begin

11      accept Start (N : Integer) do

12         Task_N := N;

13      end Start;

14      Put_Line ("In task T: "

15                & Integer'Image (Task_N));

16   end TT;

17

18   My_Tasks : array (1 .. 5) of TT;

19begin

20   Put_Line ("In main");

21

22   for I in My_Tasks'Range loop

23      My_Tasks (I).Start (I);

24   end loop;

25end Show_Task_Type_Array;

Runtime output

In main

In task T:  1

In task T:  2

In task T:  3

In task T:  4

In task T:  5

В этом примере мы объявляем пять задач в массиве My_Tasks. Мы передаем индекс в массиве отдельной задаче вызвав вход (Start). После синхронизации между отдельными подзадачами и основной задачей каждая подзадача одновременно вызывает Put_Line.

Защищенные типы

Защищенный тип - это обобщение защищенного объекта. Объявление аналогично объявлению для защищенных объектов: вы заменяете protected на protected type. Как и в случае задачных типов, защищенные типы требуют объявления объекта для создания реальных объектов. Опять же, это похоже на объявления переменных и позволяет создавать массивы (или другие составные объекты) из защищенных объектов.

Мы можем повторно использовать предыдущий пример и переписать его, чтобы использовать защищенный тип:

show_protected_object_type.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Protected_Object_Type is

4

5   protected type Obj_Type is

6      procedure Set (V : Integer);

7      function Get return Integer;

8   private

9      Local : Integer := 0;

10   end Obj_Type;

11

12   protected body Obj_Type is

13      procedure Set (V : Integer) is

14      begin

15         Local := V;

16      end Set;

17

18      function Get return Integer is

19      begin

20         return Local;

21      end Get;

22   end Obj_Type;

23

24   Obj : Obj_Type;

25begin

26   Obj.Set (5);

27   Put_Line ("Number is: "

28             & Integer'Image (Obj.Get));

29end Show_Protected_Object_Type;

Runtime output

Number is:  5

В этом примере вместо непосредственного определения объекта Obj мы сначала определяем защищенный тип Obj_Type а затем объявляем Obj как объект этого защищенного типа. Обратите внимание, что основное приложение не изменилось: мы по-прежнему используем Obj.Set и Obj.Get для доступа к защищенному объекту, как в исходном примере.

Footnotes

#1

https://eru.wikipedia.org/wiki/Поток_выполнения

#2

https://eru.wikipedia.org/wiki/Поток_выполнения#Многопоточность

Контрактное проектирование

Контракты используются в программировании чтобы сформулировать ожидания. Виды параметров подпрограммы можно рассматривать как простую форму контрактов. Когда спецификация подпрограммы Op объявляет параметр, вида in, вызывающий Op знает, что аргумент in не будет изменен Op. Другими словами, вызывающий ожидает, что Op не изменяет предоставляемый им аргумент, а просто читает информацию, хранящуюся в аргументе. Ограничения и подтипы являются другими примерами контрактов. В целом, эти спецификации улучшают согласованность приложения.

Контрактное программирование основывается на таких техниках, как указание пред- и постусловий, предикатов подтипов и инвариантов типов. Мы изучаем эти темы в этой главе.

Пред- и постусловия

Пред- и постусловия формализируют ожидания относительно входных и выходных параметров подпрограмм и возвращаемого значения функций. Если мы говорим, что некие требования должны быть выполнены перед вызовом подпрограммы Op, это предварительные условия. Точно так же, если определенные требования должны быть выполнены после вызова подпрограммы Op, это постусловия. Мы можем думать о предусловиях и постусловиях как об обещаниях между тем, кто вызывает и тем, кто принимает вызов подпрограммы: предусловие - это обещание от вызывающего к вызываемому, а постусловие - это обещание в обратном направлении.

Пред- и постусловия указываются с помощью спецификации аспекта в объявлении подпрограммы. Спуцификация with Pre => <условие> определяет предварительное условие, а спецификация with Post => <условие> определяет постусловие.

В следующем коде показан пример предварительных условий:

show_simple_precondition.adb

1procedure Show_Simple_Precondition is

2

3   procedure DB_Entry (Name : String;

4                       Age  : Natural)

5     with Pre => Name'Length > 0

6   is

7   begin

8      --  Missing implementation

9      null;

10   end DB_Entry;

11begin

12   DB_Entry ("John", 30);

13

14   --  Precondition will fail!

15   DB_Entry ("",     21);

16end Show_Simple_Precondition;

Runtime output

raised ADA.ASSERTIONS.ASSERTION_ERROR : failed precondition from show_simple_precondition.adb:5

В этом примере мы хотим, чтобы поле имени в нашей базе данных не содержало пустой строки. Мы реализуем это требование, используя предварительное условие, требующее, чтобы длина строки, используемой для параметра Name процедуры DB_Entry, была больше нуля. Если процедура DB_Entry вызывается с пустой строкой для параметра Name, вызов завершится неудачно, поскольку предварительное условие не выполнено.

В наборе инструментов GNAT

GNAT обрабатывает предварительные и постусловия, генерируя код для проверки утверждений (assertion) во время выполнения программы. Однако по умолчанию проверка утверждения не включена. Следовательно, чтобы проверять предварительные и постусловия во время выполнения, вам необходимо включить проверку утверждений с помощью ключа -gnata.

Прежде чем мы перейдем к следующему примеру, давайте кратко обсудим кванторные выражения, которые весьма полезны для краткого написания предварительных и постусловий. Кванторные выражения возвращают логическое значение, указывающее, соответствуют ли элементы массива или контейнера ожидаемому условию. Они имеют форму: (for all I in A'Range => <условие для A(I)>, где A - это массив, а I - индекс. Кванторные выражения, использующие for all, проверяют, выполняется ли условие для каждого элемент. Например:

(for all I in A'Range => A (I) = 0)

Это кванторные выражение истинно только тогда, когда все элементы массива A имеют нулевое значение.

Другой вид кванторных выражений использует for some. Он выглядит примерно так: (for some I in A'Range => <условие для A(I)>. И в этом случае кванторное выражение проверяет, есть ли некоторые (some) элементы (отсюда и название) для которых условие истино.

Проиллюстрируем постусловия на следующем примере:

show_simple_postcondition.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Postcondition is

4

5   type Int_8 is range -2 ** 7 .. 2 ** 7 - 1;

6

7   type Int_8_Array is

8     array (Integer range <>) of Int_8;

9

10   function Square (A : Int_8) return Int_8 is

11     (A * A)

12     with Post => (if abs A in 0 | 1

13                   then Square'Result = abs A

14                   else Square'Result > A);

15

16   procedure Square (A : in out Int_8_Array)

17     with Post => (for all I in A'Range =>

18                     A (I) = A'Old (I) * A'Old (I))

19   is

20   begin

21      for V of A loop

22         V := Square (V);

23      end loop;

24   end Square;

25

26   V : Int_8_Array := (-2, -1, 0, 1, 10, 11);

27begin

28   for E of V loop

29      Put_Line ("Original: "

30                & Int_8'Image (E));

31   end loop;

32   New_Line;

33

34   Square (V);

35   for E of V loop

36      Put_Line ("Square:   "

37                & Int_8'Image (E));

38   end loop;

39end Show_Simple_Postcondition;

Runtime output

Original: -2

Original: -1

Original:  0

Original:  1

Original:  10

Original:  11

Square:    4

Square:    1

Square:    0

Square:    1

Square:    100

Square:    121

Мы объявляем 8-битный тип со знаком Int_8 и массив элементов этого типа (Int_8_Array). Мы хотим убедиться, что после вызова процедуры Square каждый элемент массива Int_8_Array возведен в квадрат. Мы делаем это с помощью постусловия, используя выражение for all. Это постусловие использует атрибут 'Old чтобы сослаться на исходное (до вызова) значение параметра.

Мы также хотим убедиться, что результат вызовов функции Square больше, чем аргумент этого вызова. Для этого мы пишем постусловие, применяя атрибут 'Result к именем функции и сравниваем его с входным значением.

Мы можем использовать как предварительные, так и постусловия в объявлении одной подпрограммы. Например:

show_simple_contract.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Contract is

4

5   type Int_8 is range -2 ** 7 .. 2 ** 7 - 1;

6

7   function Square (A : Int_8) return Int_8 is

8     (A * A)

9     with

10          Pre  => (Integer'Size >= Int_8'Size * 2

11                   and Integer (A) * Integer (A) <=

12                       Integer (Int_8'Last)),

13          Post => (if abs A in 0 | 1

14                   then Square'Result = abs A

15                   else Square'Result > A);

16

17   V : Int_8;

18begin

19   V := Square (11);

20   Put_Line ("Square of 11 is " & Int_8'Image (V));

21

22   --  Precondition will fail...

23   V := Square (12);

24   Put_Line ("Square of 12 is " & Int_8'Image (V));

25end Show_Simple_Contract;

Runtime output

Square of 11 is  121

raised ADA.ASSERTIONS.ASSERTION_ERROR : failed precondition from show_simple_contract.adb:10

В этом примере мы хотим убедиться, что входной аргумент вызовова функции Square не вызовет переполнения типа Int_8 в нашей функции. Мы делаем это путем преобразования входного значения в тип Integer, который используется для промежуточных вычислений, и проверяем, находится ли результат в допустимом для типа Int_8 диапазоне. В этом примере у нас то же постусловие, что и в предыдущем.

Предикаты

Предикаты определяют ожидания касающиеся типов. Они похожи на предусловия и постусловия, но применяются к типам, а не к подпрограммам. Их условия проверяются для каждого объекта данного типа, что позволяет убедиться, что объект типа T соответствует требованиям, указанным для данного типа.

Есть два вида предикатов: статические и динамические. Проще говоря, статические предикаты используются для проверки объектов во время компиляции, а динамические предикаты используются для проверок во время выполнения. Обычно статические предикаты используются для скалярных типов и динамические предикаты для более сложных типов.

Статические и динамические предикаты указываются с помощью следующих спецификаций:

- with Static_Predicate => <свойство>

- with Dynamic_Predicate => <свойство>

Давайте воспользуемся следующим примером, чтобы проиллюстрировать динамические предикаты:

show_dynamic_predicate_courses.adb

1with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

2with Ada.Calendar;          use Ada.Calendar;

3with Ada.Containers.Vectors;

4

5procedure Show_Dynamic_Predicate_Courses is

6

7   package Courses is

8      type Course_Container is private;

9

10      type Course is record

11         Name       : Unbounded_String;

12         Start_Date : Time;

13         End_Date   : Time;

14      end record

15        with Dynamic_Predicate =>

16          Course.Start_Date <= Course.End_Date;

17

18      procedure Add (CC : in out Course_Container;

19                     C  :        Course);

20   private

21      package Course_Vectors is new

22        Ada.Containers.Vectors

23          (Index_Type   => Natural,

24           Element_Type => Course);

25

26      type Course_Container is record

27         V : Course_Vectors.Vector;

28      end record;

29   end Courses;

30

31   package body Courses is

32      procedure Add (CC : in out Course_Container;

33                     C  :        Course) is

34      begin

35         CC.V.Append (C);

36      end Add;

37   end Courses;

38

39   use Courses;

40

41   CC : Course_Container;

42begin

43   Add (CC,

44        Course'(

45          Name       => To_Unbounded_String

46                         ("Intro to Photography"),

47          Start_Date => Time_Of (2018, 5, 1),

48          End_Date   => Time_Of (2018, 5, 10)));

49

50   --  This should trigger an error in the

51   --  dynamic predicate check

52   Add (CC,

53        Course'(

54          Name       => To_Unbounded_String

55                         ("Intro to Video Recording"),

56          Start_Date => Time_Of (2019, 5, 1),

57          End_Date   => Time_Of (2018, 5, 10)));

58

59end Show_Dynamic_Predicate_Courses;

Runtime output

raised ADA.ASSERTIONS.ASSERTION_ERROR : Dynamic_Predicate failed at show_dynamic_predicate_courses.adb:53

В этом примере пакет Courses определяет тип Course и тип Course_Container, объект которого содержит все курсы. Мы хотим обеспечить согласованность дат каждого курса, в частности, чтобы дата начала была не позже даты окончания. Чтобы обеспечить соблюдение этого правила, мы объявляем динамический предикат для типа Course, который будет действовать для каждого объекта. Предикат использует имя типа, так как будь-то это обычная переменная данного типа: такое имя обозначает экземпляр проверяемого объекта.

Обратите внимание, что в приведенном выше примере используются неограниченные строки и даты. Оба типа доступны в стандартной библиотеке Ада. Пожалуйста, обратитесь к следующим разделам для получения дополнительной информации:

- о типе неограниченной строки (Unbounded_String): раздел Неограниченные строки;

- о дате и времени: Раздел Даты и время.

Статические предикаты, как упоминалось выше, в основном используются для скалярных типов и проверяются во время компиляции. Они особенно полезны для представления несмежных элементов перечисления. Классический пример - список дней недели:

type Week is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);

Мы можем легко создать подсписок рабочих дней в неделе, указав подтип (subtype) с диапазоном на основе Week. Например:

subtype Work_Week is Week range Mon .. Fri;

Диапазоны в Аде могут быть указаны только как непрерывные списки: они не позволяют нам выбирать определенные дни. Однако нам может понадобиться создать список, содержащий только первый, средний и последний день рабочей недели. Для этого мы используем статический предикат:

subtype Check_Days is Work_Week

with Static_Predicate => Check_Days in Mon | Wed | Fri;

Давайте посмотрим на полный пример:

show_predicates.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Predicates is

4

5   type Week is (Mon, Tue, Wed, Thu,

6                 Fri, Sat, Sun);

7

8   subtype Work_Week is Week range Mon .. Fri;

9

10   subtype Test_Days is Work_Week

11     with Static_Predicate =>

12       Test_Days in Mon | Wed | Fri;

13

14   type Tests_Week is array (Week) of Natural

15     with Dynamic_Predicate =>

16       (for all I in Tests_Week'Range =>

17          (case I is

18               when Test_Days =>

19                  Tests_Week (I) > 0,

20               when others    =>

21                  Tests_Week (I) = 0));

22

23   Num_Tests : Tests_Week :=

24                 (Mon => 3, Tue => 0,

25                  Wed => 4, Thu => 0,

26                  Fri => 2, Sat => 0,

27                  Sun => 0);

28

29   procedure Display_Tests (N : Tests_Week) is

30   begin

31      for I in Test_Days loop

32         Put_Line ("# tests on "

33                   & Test_Days'Image (I)

34                   & " => "

35                   & Integer'Image (N (I)));

36      end loop;

37   end Display_Tests;

38

39begin

40   Display_Tests (Num_Tests);

41

42   --  Assigning non-conformant values to

43   --  individual elements of the Tests_Week

44   --  type does not trigger a predicate

45   --  check:

46   Num_Tests (Tue) := 2;

47

48   --  However, assignments with the "complete"

49   --  Tests_Week type trigger a predicate

50   --  check. For example:

51   --

52   --  Num_Tests := (others => 0);

53

54   --  Also, calling any subprogram with

55   --  parameters of Tests_Week type

56   --  triggers a predicate check. Therefore,

57   --  the following line will fail:

58   Display_Tests (Num_Tests);

59end Show_Predicates;

Runtime output

# tests on MON =>  3

# tests on WED =>  4

# tests on FRI =>  2

raised ADA.ASSERTIONS.ASSERTION_ERROR : Dynamic_Predicate failed at show_predicates.adb:58

Здесь у нас есть приложение, которое хочет проводить тесты только три дня в рабочей неделе. Эти дни указаны в подтипе Test_Days. Мы хотим отслеживать количество тестов, которые проводятся каждый день. Мы объявляем тип Tests_Week как массив, объект которого будет содержать количество тестов, выполняемых каждый день. Согласно нашим требованиям, эти тесты должны проводиться только в вышеупомянутые три дня; в другие дни никаких анализов проводить не следует. Это требование реализовано с помощью динамического предиката типа Tests_Week. Наконец, фактическая информация об этих тестах хранится в массиве Num_Tests, который является экземпляром типа Tests_Week.

Динамический предикат типа Tests_Week проверяется во время инициализации Num_Tests. Если у нас там будет несоответствующее значение, проверка не удастся. Однако, как мы видим в нашем примере, изменения отдельных элементов массива не приводят к выполнению проверки. Так происходит потому, что инициализация сложной структуры данных (например, массивов или записей) может требовать выполнения нескольких операций присваивания. Однако, как только объект передается в качестве аргумента подпрограмме, динамический предикат проверяется, потому что подпрограмма требует, чтобы объект был согласован. Это происходит при вызове Display_Tests в последнем операторе нашего примера. Здесь проверка предиката вызовет ошибку потому, что предыдущее изменение приводит к несогласованному значению.

Инварианты типа

Инварианты типов - это еще один способ определить ожидания относительно типов. В то время как предикаты используются для всех типов, инварианты типов используются исключительно для определения ожиданий в отношении личных типов. Если тип T из пакета P имеет инвариант типа, результаты операций с объектами типа T всегда согласуются с этим инвариантом.

Инварианты типов указываются с помощью предложения with Type_Invariant => <свойство>. Подобно предикатам, свойство определяет условие, которое позволяет нам контролировать, соответствует ли объект типа T нашим требованиям. В этом смысле инварианты типов можно рассматривать как своего рода предикаты для личных типов. Однако есть некоторые отличия касающиеся проверок. Эти отличия приведены в следующей таблице:

Элемент

Проверки параметров подпрограммы

Проверки присвоения

Предикаты

По всем входящим  in и выходящим out параметрам

При присваивании и явных инициализациях

Инварианты типов

По параметрам  out, возвращенным из подпрограмм, объявленных в том же видимом разделе

При всех инициализациях

Мы могли бы переписать наш предыдущий пример и заменить динамические предикаты инвариантами типов. Это выглядело бы так:

show_type_invariant.adb

1with Ada.Text_IO;           use Ada.Text_IO;

2with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

3with Ada.Calendar;          use Ada.Calendar;

4with Ada.Containers.Vectors;

5

6procedure Show_Type_Invariant is

7

8   package Courses is

9      type Course is private

10        with Type_Invariant => Check (Course);

11

12      type Course_Container is private;

13

14      procedure Add (CC : in out Course_Container;

15                     C  :        Course);

16

17      function Init

18        (Name                 : String;

19         Start_Date, End_Date : Time) return Course;

20

21      function Check (C : Course) return Boolean;

22

23   private

24      type Course is record

25         Name       : Unbounded_String;

26         Start_Date : Time;

27         End_Date   : Time;

28      end record;

29

30      function Check (C : Course) return Boolean is

31        (C.Start_Date <= C.End_Date);

32

33      package Course_Vectors is new

34        Ada.Containers.Vectors

35          (Index_Type   => Natural,

36           Element_Type => Course);

37

38      type Course_Container is record

39         V : Course_Vectors.Vector;

40      end record;

41   end Courses;

42

43   package body Courses is

44      procedure Add (CC : in out Course_Container;

45                     C  :        Course) is

46      begin

47         CC.V.Append (C);

48      end Add;

49

50      function Init

51        (Name                 : String;

52         Start_Date, End_Date : Time) return Course is

53      begin

54         return

55           Course'(Name       => To_Unbounded_String (Name),

56                   Start_Date => Start_Date,

57                   End_Date   => End_Date);

58      end Init;

59   end Courses;

60

61   use Courses;

62

63   CC : Course_Container;

64begin

65   Add (CC,

66        Init (Name       => "Intro to Photography",

67              Start_Date => Time_Of (2018, 5, 1),

68              End_Date   => Time_Of (2018, 5, 10)));

69

70   --  This should trigger an error in the

71   --  type-invariant check

72   Add (CC,

73        Init (Name       => "Intro to Video Recording",

74              Start_Date => Time_Of (2019, 5, 1),

75              End_Date   => Time_Of (2018, 5, 10)));

76end Show_Type_Invariant;

Build output

show_type_invariant.adb:1:09: warning: no entities of "Ada.Text_IO" are referenced [-gnatwu]

show_type_invariant.adb:1:29: warning: use clause for package "Text_IO" has no effect [-gnatwu]

Runtime output

raised ADA.ASSERTIONS.ASSERTION_ERROR : failed invariant from show_type_invariant.adb:10

Основное отличие состоит в том, что в предыдущем примере тип Course был полностью описан в видимом разделе пакета Courses, но в этом примере он является личным типом.

Footnotes

Взаимодействие с языком C

Ада позволяет нам взаимодействовать с кодом на многих языках, включая C и C++. В этом разделе обсуждается, как взаимодействовать с C.

Многоязычный проект

По умолчанию при использовании gprbuild мы компилируем только исходные файлы Ада. Чтобы скомпилировать файлы C, нам нужно изменить файл проекта, используемый gprbuild. Мы добавляем запись Languages, как в следующем примере:

project Multilang is

for Languages use ("ada", "c");

for Source_Dirs use ("src");

for Main use ("main.adb");

for Object_Dir use "obj";

end Multilang;

Соглашение о типах

Для взаимодействия с типами данных, объявленными в приложении на C, необходимо указать аспект Convention в соответствующем объявлении типа Ада. В следующем примере вводим перечисленимый тип C_Enum, для соответствующего типа в исходном файле C:

show_c_enum.adb

1procedure Show_C_Enum is

2

3   type C_Enum is (A, B, C)

4     with Convention => C;

5   --  Use C convention for C_Enum

6begin

7   null;

8end Show_C_Enum;

Для взаимодействия со встроенными типами C используется пакет Interfaces.C, содержащий большинство необходимых определений типов. Например:

show_c_struct.adb

1with Interfaces.C; use Interfaces.C;

2

3procedure Show_C_Struct is

4

5   type c_struct is record

6      a : int;

7      b : long;

8      c : unsigned;

9      d : double;

10   end record

11     with Convention => C;

12

13begin

14   null;

15end Show_C_Struct;

Здесь мы взаимодействуем со структурой C (C_Struct) и используем соответствующие типы данных C (int, long, unsigned и double). А вот объявление в C:

c_struct.h

1struct c_struct

2{

3    int         a;

4    long        b;

5    unsigned    c;

6    double      d;

7};

Подпрограммы на других языках

Вызов подпрограмм C из Ады

Мы используем аналогичный подход при взаимодействии с подпрограммами, написанными на C. Рассмотрим следующее объявление в заголовочном файле C:

my_func.h

1int my_func (int a);

Вот соответствующее определение функции на C:

my_func.c

1#include "my_func.h"

2

3int my_func (int a)

4{

5    return a * 2;

6}

Мы можем связать этот код с кодом на Аде, указывая аспект Import. Например:

show_c_func.adb

1with Interfaces.C; use Interfaces.C;

2with Ada.Text_IO;  use Ada.Text_IO;

3

4procedure Show_C_Func is

5

6   function my_func (a : int) return int

7     with

8       Import        => True,

9       Convention    => C;

10

11   --  Imports function 'my_func' from C.

12   --  You can now call it from Ada.

13

14   V : int;

15begin

16   V := my_func (2);

17   Put_Line ("Result is " & int'Image (V));

18end Show_C_Func;

При необходимости можно использовать другое имя подпрограммы в Ада коде. Например, можно назвать функцию Get_Value:

show_c_func.adb

1with Interfaces.C; use Interfaces.C;

2with Ada.Text_IO;  use Ada.Text_IO;

3

4procedure Show_C_Func is

5

6   function Get_Value (a : int) return int

7     with

8       Import        => True,

9       Convention    => C,

10       External_Name => "my_func";

11

12   --  Imports function 'my_func' from C and

13   --  rename it to 'Get_Value'

14

15   V : int;

16begin

17   V := Get_Value (2);

18   Put_Line ("Result is " & int'Image (V));

19end Show_C_Func;

Вызов Ада подпрограмм из C

Вы также можете вызывать Ада подпрограммы из C приложений. Это делается с помощью аспекта Export. Например:

c_api.ads

1with Interfaces.C; use Interfaces.C;

2

3package C_API is

4

5   function My_Func (a : int) return int

6     with

7       Export        => True,

8       Convention    => C,

9       External_Name => "my_func";

10

11end C_API;

Вот соответствующее тело пакета с реализфцией этой функции:

c_api.adb

1package body C_API is

2

3   function My_Func (a : int) return int is

4   begin

5      return a * 2;

6   end My_Func;

7

8end C_API;

На стороне C мы делаем так, как если бы функция была написана на C: просто объявляем ее с помощью ключевого слова extern. Например:

main.c

1#include <stdio.h>

2

3extern int my_func (int a);

4

5int main (int argc, char **argv) {

6

7  int v = my_func(2);

8

9  printf("Result is %d\n", v);

10

11  return 0;

12}

Внешние переменные

Использование глобальных переменных C в Аде

Чтобы использовать глобальные переменные из C, мы используем тот же метод, что и для подпрограмм: мы указываем аспекты Import и Convention для каждой переменной, которую мы хотим импортировать.

Давайте воспользуемся примером из предыдущего раздела. Мы добавим глобальную переменную (func_cnt) для подсчета количества вызовов функции (my_func):

test.h

1extern int func_cnt;

2

3int my_func (int a);

Переменная объявлена в файле C и увеличивается в my_func:

test.c

1#include "test.h"

2

3int func_cnt = 0;

4

5int my_func (int a)

6{

7  func_cnt++;

8

9  return a * 2;

10}

В коде на Аде мы просто ссылаемся на внешнюю переменную:

show_c_func.adb

1with Interfaces.C; use Interfaces.C;

2with Ada.Text_IO;  use Ada.Text_IO;

3

4procedure Show_C_Func is

5

6   function my_func (a : int) return int

7     with

8       Import     => True,

9       Convention => C;

10

11   V : int;

12

13   func_cnt : int

14     with

15       Import        => True,

16       Convention    => C;

17   --  We can access the func_cnt variable

18   --  from test.c

19

20begin

21   V := my_func (1);

22   V := my_func (2);

23   V := my_func (3);

24   Put_Line ("Result is " & int'Image (V));

25

26   Put_Line ("Function was called "

27             & int'Image (func_cnt)

28             & " times");

29end Show_C_Func;

Как мы видим, запустив приложение, значение счетчика - это количество вызовов my_func.

Мы можем использовать аспект External_Name, если хотим сослаться на имя отличное от наименования переменной в Аде, как мы это делали для подпрограмм.

Использование переменных Ада в C

Вы также можете использовать переменные, объявленные в файлах Ада, в приложениях C. Точно так же, как мы делали для подпрограмм, вы делаете это с помощью аспекта Export.

Давайте повторно воспользуемся прошлым примером и добавим счетчик, аналогично предыдущему примеру, но на этот раз будем увеличивать счетчик в Ада коде:

c_api.ads

1with Interfaces.C; use Interfaces.C;

2

3package C_API is

4

5   func_cnt : int := 0

6     with

7       Export     => True,

8       Convention => C;

9

10   function My_Func (a : int) return int

11     with

12       Export        => True,

13       Convention    => C,

14       External_Name => "my_func";

15

16end C_API;

Затем переменная увеличивается в My_Func:

c_api.adb

1package body C_API is

2

3   function My_Func (a : int) return int is

4   begin

5      func_cnt := func_cnt + 1;

6      return a * 2;

7   end My_Func;

8

9end C_API;

В приложении C нам просто нужно объявить переменную и использовать ее:

main.c

1#include <stdio.h>

2

3extern int my_func (int a);

4

5extern int func_cnt;

6

7int main (int argc, char **argv) {

8

9  int v;

10

11  v = my_func(1);

12  v = my_func(2);

13  v = my_func(3);

14

15  printf("Result is %d\n", v);

16

17  printf("Function was called %d times\n", func_cnt);

18

19  return 0;

20}

Опять же, запустив приложение, мы видим, что значение счетчика - это количество вызовов my_func.

Автоматическое создание связок

В приведенных выше примерах мы вручную добавили аспекты в наш код Ада, чтобы они соответствовали исходному коду C, с которым мы взаимодействуем. Это называется созданием cвязки. Мы можем автоматизировать этот процесс, используя особый ключ компилятора для дампа спецификации Ада: -fdump-ada-spec. Мы проиллюстрируем это, вернувшись к нашему предыдущему примеру.

Это был наш заголовочный файл C:

my_func.c

1extern int func_cnt;

2

3int my_func (int a);

Чтобы создать связку на Аде, мы вызовем компилятор следующим образом:

gcc -c -fdump-ada-spec -C ./test.h

Результатом является файл спецификации Ада с именем test_h.ads:

test_h.ads

1pragma Ada_2005;

2pragma Style_Checks (Off);

3

4with Interfaces.C; use Interfaces.C;

5

6package test_h is

7

8   func_cnt : aliased int;  -- ./test.h:3

9   pragma Import (C, func_cnt, "func_cnt");

10

11   function my_func (arg1 : int) return int;  -- ./test.h:5

12   pragma Import (C, my_func, "my_func");

13

14end test_h;

Теперь мы просто ссылаемся на этот пакет test_h в нашем приложении Ада:

show_c_func.adb

1with Interfaces.C; use Interfaces.C;

2with Ada.Text_IO;  use Ada.Text_IO;

3with test_h;       use test_h;

4

5procedure Show_C_Func is

6   V : int;

7begin

8   V := my_func (1);

9   V := my_func (2);

10   V := my_func (3);

11   Put_Line ("Result is " & int'Image (V));

12

13   Put_Line ("Function was called "

14             & int'Image (func_cnt)

15             & " times");

16end Show_C_Func;

Вы можете указать имя родительского модуля создаваемых связок в качестве операнда для fdump-ada-spec:

gcc -c -fdump-ada-spec -fada-spec-parent=Ext_C_Code -C ./test.h

И получим файл ext_c_code-test_h.ads:

ext_c_code-test_h.ads

1package Ext_C_Code.test_h is

2

3   --  automatic generated bindings...

4

5end Ext_C_Code.test_h;

Адаптация связок

Компилятор делает все возможное при создании связок для файла заголовка C. Однако мы получаем достаточно хороший результат и сгенерированные связки не всегда соответствуют нашим ожиданиям. Например, так может произойти при создании связок для функций, которые имеют указатели в качестве аргументов. В этом случае компилятор может использовать System.Address как тип одного или нескольких указателей. Хотя этот подход работает нормально (как мы увидим позже), обычно человек не так интерпретирует заголовочный файл C. Следующий пример иллюстрирует эту проблему.

Начнем с такого заголовочного файла C:

test.h

1struct test;

2

3struct test * test_create(void);

4

5void test_destroy(struct test *t);

6

7void test_reset(struct test *t);

8

9void test_set_name(struct test *t, char *name);

10

11void test_set_address(struct test *t, char *address);

12

13void test_display(const struct test *t);

И соответствующей реализация на C:

test.c

1#include <stdlib.h>

2#include <string.h>

3#include <stdio.h>

4

5#include "test.h"

6

7struct test {

8  char name[80];

9  char address[120];

10};

11

12static size_t

13strlcpy(char *dst, const char *src, size_t dstsize)

14{

15  size_t len = strlen(src);

16  if (dstsize) {

17    size_t bl = (len < dstsize-1 ? len : dstsize-1);

18    ((char*)memcpy(dst, src, bl))[bl] = 0;

19  }

20  return len;

21}

22

23struct test * test_create(void)

24{

25  return malloc (sizeof (struct test));

26}

27

28void test_destroy(struct test *t)

29{

30  if (t != NULL) {

31    free(t);

32  }

33}

34

35void test_reset(struct test *t)

36{

37  t->name[0]    = '\0';

38  t->address[0] = '\0';

39}

40

41void test_set_name(struct test *t, char *name)

42{

43  strlcpy(t->name, name, sizeof(t->name));

44}

45

46void test_set_address(struct test *t, char *address)

47{

48  strlcpy(t->address, address, sizeof(t->address));

49}

50

51void test_display(const struct test *t)

52{

53  printf("Name:    %s\n", t->name);

54  printf("Address: %s\n", t->address);

55}

Далее мы создадим наши связки:

gcc -c -fdump-ada-spec -C ./test.h

Это создает следующую спецификацию в test_h.ads:

test_h.ads

1pragma Ada_2005;

2pragma Style_Checks (Off);

3

4with Interfaces.C; use Interfaces.C;

5with System;

6with Interfaces.C.Strings;

7

8package test_h is

9

10   --  skipped empty struct test

11

12   function test_create return System.Address;  -- ./test.h:5

13   pragma Import (C, test_create, "test_create");

14

15   procedure test_destroy (arg1 : System.Address);  -- ./test.h:7

16   pragma Import (C, test_destroy, "test_destroy");

17

18   procedure test_reset (arg1 : System.Address);  -- ./test.h:9

19   pragma Import (C, test_reset, "test_reset");

20

21   procedure test_set_name (arg1 : System.Address; arg2 : Interfaces.C.Strings.chars_ptr);  -- ./test.h:11

22   pragma Import (C, test_set_name, "test_set_name");

23

24   procedure test_set_address (arg1 : System.Address; arg2 : Interfaces.C.Strings.chars_ptr);  -- ./test.h:13

25   pragma Import (C, test_set_address, "test_set_address");

26

27   procedure test_display (arg1 : System.Address);  -- ./test.h:15

28   pragma Import (C, test_display, "test_display");

29

30end test_h;

Как мы видим, генератор связки полностью игнорирует объявление struct test, и все ссылки на структуру test заменяются адресами (System.Address). Тем не менее, эти связки достаточно хороши, чтобы позволить нам создать тестовое приложение на Ада:

show_automatic_c_struct_bindings.adb

1with Interfaces.C;         use Interfaces.C;

2with Interfaces.C.Strings; use Interfaces.C.Strings;

3with Ada.Text_IO;          use Ada.Text_IO;

4with test_h;               use test_h;

5

6with System;

7

8procedure Show_Automatic_C_Struct_Bindings is

9

10   Name    : constant chars_ptr :=

11     New_String ("John Doe");

12   Address : constant chars_ptr :=

13     New_String ("Small Town");

14

15   T : System.Address := test_create;

16

17begin

18   test_reset (T);

19   test_set_name (T, Name);

20   test_set_address (T, Address);

21

22   test_display (T);

23   test_destroy (T);

24end Show_Automatic_C_Struct_Bindings;

Мы можем успешно собрать такую программу, используя автоматически сгенерированные связки, но они не идеальны. Вместо этого мы предпочли бы связки на Аде, которые соответствуют нашей (человеческой) интерпретации файла заголовка C. Это требует ручного анализа файла заголовка. Хорошая новость заключается в том, что мы можем использовать автоматически сгенерированные связки в качестве отправной точки и адаптировать их к нашим потребностям. Например, мы можем:

1. Определить тип Test на основе System.Address и использовать его во всех соответствующих функциях.

2. Удалить префикс test_ во всех операциях с типом Test.

Вот итоговая версия спецификации:

adapted_test_h.ads

1with Interfaces.C; use Interfaces.C;

2with System;

3with Interfaces.C.Strings;

4

5package adapted_test_h is

6

7   type Test is new System.Address;

8

9   function Create return Test;

10   pragma Import (C, Create, "test_create");

11

12   procedure Destroy (T : Test);

13   pragma Import (C, Destroy, "test_destroy");

14

15   procedure Reset (T : Test);

16   pragma Import (C, Reset, "test_reset");

17

18   procedure Set_Name (T    : Test;

19                       Name : Interfaces.C.Strings.chars_ptr);  -- ./test.h:11

20   pragma Import (C, Set_Name, "test_set_name");

21

22   procedure Set_Address (T       : Test;

23                          Address : Interfaces.C.Strings.chars_ptr);

24   pragma Import (C, Set_Address, "test_set_address");

25

26   procedure Display (T : Test);  -- ./test.h:15

27   pragma Import (C, Display, "test_display");

28

29end adapted_test_h;

И это соответствующее тело на Аде:

show_adapted_c_struct_bindings.adb

1with Interfaces.C;         use Interfaces.C;

2with Interfaces.C.Strings; use Interfaces.C.Strings;

3with adapted_test_h;       use  adapted_test_h;

4

5with System;

6

7procedure Show_Adapted_C_Struct_Bindings is

8

9   Name    : constant chars_ptr :=

10     New_String ("John Doe");

11   Address : constant chars_ptr :=

12     New_String ("Small Town");

13

14   T : Test := Create;

15

16begin

17   Reset (T);

18   Set_Name (T, Name);

19   Set_Address (T, Address);

20

21   Display (T);

22   Destroy (T);

23end Show_Adapted_C_Struct_Bindings;

Теперь мы можем использовать тип Test и его операции в понятной и удобочитаемой форме.

Footnotes

Объектно-ориентированное программирование

Объектно-ориентированное программирование (ООП) - это большая и расплывчатая концепция в языках программирования, которая имеет тенденцию включать в себя множество различных элементов, потому, что разные языки часто реализуют свое собственное видение этой концепции, предлагая в чем-то сходные, а в чем-то отличающиеся реализации.

Но одна из моделей, можно сказать, «выиграла» битву за звания "истинного" объектно-ориентированного подхода, хотя бы, если судить только по популярности. Это модель, используется в языке программирования Java, и она очень похожа на модель, используемую в C ++. Вот некоторые важные характеристики:

- Производные типы и расширение типов: Большинство объектно-ориентированных языков позволяют пользователю добавлять новые поля в производные типы.

- Заменяемость подтипов: Объекты типа, производного от базового типа, в некоторых случаях, могут использоваться вместо объектов базового типа.

- Полиморфизм среды выполнения: Вызов подпрограммы, обычно называемой методом, привязанной к типу объекта, может диспечеризироваться во время выполнения программы в зависимости от конкретного типа объекта.

- Инкапсуляция: Объекты могут скрывать некоторые свои данные.

- Расширяемость: пользователи "извне" вашего пакета или даже всей вашей библиотеки могут создавать производные от ваших объектных типов и определять их поведение по своему.

Ада появилась еще до того, как объектно-ориентированное программирование стало таким уж популярным, как и сегодня. Некоторые механизмы и концепции из приведенного выше списка были в самой ранней версии Ада еще до того, как было добавлено то, что мы бы назвали поддержкой ООП:

- Как мы видели, инкапсуляция реализована в Аде не на уровне типа, а на уровне пакета.

- Заменяемость подтипов может быть реализована с использованием, ну да, подтипов, которые имеют полную и "разрешительную" (permissive) статическую модель замещаемости. Во время выполнения замена завершится неудачно, если динамические ограничения подтипа будут нарушены.

- Полиморфизм времени выполнения может быть реализован с использованием записей с вариантами.

Однако в этом списке нет расширения типов, если вы не считать записи с вариантами, и расширяемости.

Редакция Ада 1995 года добавила функцию, заполняющую пробелы, которая позволила людям проще программировать, следуя объектно-ориентированной парадигме. Эта функция называется теговые типы.

Note

Примечание: В Ада можно написать программу не создав даже одного тегового типа. Если вы предпочитаете такой стиль программирования или вам в данный момент не нужны теговые типы, это нормально не использовать их, как в случае и со многими другими возможностями Ады.

Тем не менее, может оказаться, что они - наилучший способ выразить решение вашей задачи. А, раз это так, читайте дальше!

Производные типы

Прежде чем представить теговые типы, мы должны обсудить тему, которой мы уже касались, но на самом деле не углублялись в нее до сих пор:

Вы можете создать один или несколько новых типов из любого типа языка Ада. Производные типы встроены в язык.

newtypes.ads

1package Newtypes is

2   type Point is record

3       X, Y : Integer;

4   end record;

5

6   type New_Point is new Point;

7end Newtypes;

Наследование типов полезно для обеспечения строгой типизации, поскольку система типов рассматривает эти два типа как несовместимые.

Но этим дело не ограничивается: создавая производный тип вы наследуете от него многое. Вы наследуете не только представление данных, но также можете унаследовать и поведение.

Когда вы наследуете тип, вы также наследуете так называемые примитивные операции. Примитивная операция (или просто примитив) - это подпрограмма, привязанная к типу. Ада определяет примитивы как подпрограммы, определенные в той же области, что и тип.

Attention

Обратите внимание: подпрограмма станет примитивом этого типа только в том случае, если:

1. Подпрограмма объявляется в той же области, что и тип и

2. Тип и подпрограмма объявляются в пакете.

primitives.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Primitives is

4  package Week is

5    type Days is (Monday, Tuesday, Wednesday,

6                  Thursday, Friday,

7                  Saturday, Sunday);

8

9     --  Print_Day is a primitive

10     --  of the type Days

11    procedure Print_Day (D : Days);

12  end Week;

13

14  package body Week is

15    procedure Print_Day (D : Days) is

16    begin

17       Put_Line (Days'Image (D));

18    end Print_Day;

19  end Week;

20

21  use Week;

22  type Weekend_Days is new

23    Days range Saturday .. Sunday;

24

25  --  A procedure Print_Day is automatically

26  --  inherited here. It is as if the procedure

27  --

28  --  procedure Print_Day (D : Weekend_Days);

29  --

30  --  has been declared with the same body

31

32  Sat : Weekend_Days := Saturday;

33begin

34   Print_Day (Sat);

35end Primitives;

Build output

primitives.adb:11:15: warning: procedure "Print_Day" is not referenced [-gnatwu]

primitives.adb:32:03: warning: "Sat" is not modified, could be declared constant [-gnatwk]

Runtime output

SATURDAY

Этот вид наследования может быть очень полезным и не ограничивается типами записей (вы можете использовать его и для дискретных типов, как в примере выше), но он лишь внешне похож на объектно-ориентированное наследование:

- Записи не могут быть расширены с помощью этого механизма. Вы также не можете указать новое представление для нового типа: оно всегда будет то же, что и у базового типа. (Прим. пер: На самом деле, это не так и производные типы часто используются чтобы выполнять преобразование внутреннего представления типа.)

- Нет возможности для динамической диспетчеризации или полиморфизма. Объекты имеют фиксированный, статический тип.

Есть и другие различия, но перечислять их все здесь нет смысла. Просто помните, что эту форму наследования вы можете использовать, если хотите иметь только статически унаследованое поведение, избежать дублирования кода и использования композиции, и которое вам не подходит, если вам нужны какие-либо динамические возможности, которые обычно ассоциируются с ООП.

Теговые типы

Версия языка Ада 1995 года представила теговые типы, чтобы удовлетворить потребность в едином решении, которое позволяет программировать в объектно-ориентированном стиле, аналогичном тому, что был описан в начале этой главы.

Теговые типы очень похожи на обычные записи, за исключением того, что добавлена следующая функциональность:

- Типы имеют тег, хранящийся внутри каждого объекта и необходимый чтобы определить тип объекта во время выполнения#1.

- Для примитивов может приминяться диспечеризация. Примитив тегового типа - это то, что вы бы назвали методом в Java или C++. Если у вас есть тип, производный от базового типа с переопределенным примитивом, то при вызове примитива для объекта, какой примитив вызовется будет зависить от точного типа объекта в момент исполнения.

- Введены специальные правила, позволяющие теговому типу, производному от базового типа, быть статически совместимым с базовым типом.

Давайте посмотрим на наши первые объявления тегового типа:

p.ads

1package P is

2   type My_Class is tagged null record;

3   --  Just like a regular record, but

4   --  with tagged qualifier

5

6   --  Methods are outside of the type

7   --  definition:

8

9   procedure Foo (Self : in out My_Class);

10   --  If you define a procedure taking a

11   --  My_Class argument in the same package,

12   --  it will be a method.

13

14   --  Here's how you derive a tagged type:

15

16   type Derived is new My_Class with record

17       A : Integer;

18       --  You can add fields in derived types.

19   end record;

20

21   overriding procedure Foo (Self : in out Derived);

22   --  The "overriding" qualifier is optional,

23   --  but if it is present, it must be valid.

24end P;

p.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body P is

4   procedure Foo (Self : in out My_Class) is

5   begin

6      Put_Line ("In My_Class.Foo");

7   end Foo;

8

9   procedure Foo (Self : in out Derived) is

10   begin

11      Put_Line ("In Derived.Foo, A = "

12                & Integer'Image (Self.A));

13   end Foo;

14end P;

Надклассовые типы

Чтобы сохранить согласованность языка, необходимо было ввести новую нотацию, обозначающую: "Данный объект относится к этому теговому типу или любому его потомку".

В Аде мы называем это надклассовым типом. Он используется в ООП, как только вам понадобится полиморфизм. Например, вы не можете выполнить следующие действия:

main.adb

1with P; use P;

2

3procedure Main is

4

5   O1 : My_Class;

6   --  Declaring an object of type My_Class

7

8   O2 : Derived := (A => 12);

9   --  Declaring an object of type Derived

10

11   O3 : My_Class := O2;

12   --  INVALID: Trying to assign a value

13   --  of type derived to a variable of

14   --  type My_Class.

15begin

16   null;

17end Main;

Build output

main.adb:11:21: error: expected type "My_Class" defined at p.ads:2

main.adb:11:21: error: found type "Derived" defined at p.ads:16

gprbuild: *** compilation phase failed

Это связано с тем, что объект типа T имеет в точности тип T, независимо от того, является T теговым или нет. То, что программист пытается тут сказать, это «Я хочу, чтобы O3 содержал объект типа My_Class или любого производного от My_Class типа». Вот как вы это делаете:

main.adb

1with P; use P;

2

3procedure Main is

4   O1 : My_Class;

5   --  Declare an object of type My_Class

6

7   O2 : Derived := (A => 12);

8   --  Declare an object of type Derived

9

10   O3 : My_Class'Class := O2;

11   --  Now valid: My_Class'Class designates

12   --  the classwide type for My_Class,

13   --  which is the set of all types

14   --  descending from My_Class (including

15   --  My_Class).

16begin

17   null;

18end Main;

Build output

main.adb:4:04: warning: variable "O1" is not referenced [-gnatwu]

main.adb:7:04: warning: "O2" is not modified, could be declared constant [-gnatwk]

main.adb:10:04: warning: variable "O3" is not referenced [-gnatwu]

Attention

Обратите внимание: Поскольку объект надклассового типа может быть размером с любого потомка его базового типа, то его размер заранее неизвестен. Таким образом, это неопределенный тип со всеми ожидаемыми ограничениями:

- Он не может быть использован для поля/компоненты записи

- Объект надклассового типа должен быть инициализирован немедленно (вы не можете ограничить такой тип каким-либо иным способом, кроме как путем его инициализации).

Операции диспетчеризации

Мы увидели, что можно переопределять операции в типах, производных от другого тегового типа. Конечной целью ООП является выполнение диспетчеризируемого вызова: когда вызоваемый примитив (метод) определяется точным типом объекта.

Но если задуматься, переменная типа My_Class всегда содержит объект именно данного типа. Если требуется переменная, которая может содержать My_Class или любой производный тип, она должна иметь тип My_Class'Class.

Другими словами, чтобы сделать диспетчеризируемый вызов, вы должны сначала получить объект, который может иметь либо конкретный тип, либо любой тип, производным от этого конкретного типа, а именно объект надклассового типа.

main.adb

1with P; use P;

2

3procedure Main is

4   O1 : My_Class;

5   --  Declare an object of type My_Class

6

7   O2 : Derived := (A => 12);

8   --  Declare an object of type Derived

9

10   O3 : My_Class'Class := O2;

11

12   O4 : My_Class'Class := O1;

13begin

14   Foo (O1);

15   --  Non dispatching: Calls My_Class.Foo

16   Foo (O2);

17   --  Non dispatching: Calls Derived.Foo

18   Foo (O3);

19   --  Dispatching: Calls Derived.Foo

20   Foo (O4);

21   --  Dispatching: Calls My_Class.Foo

22end Main;

Runtime output

In My_Class.Foo

In Derived.Foo, A =  12

In Derived.Foo, A =  12

In My_Class.Foo

Внимание

Вы можете преобразовать объект типа Derived в объект типа My_Class. В Аде это называется преобразованием представления и полезно, например, если вы хотите вызвать родительский метод.

В том случае, когда объект действительно преобразуется в объект My_Class, что включает изменение его тега. Поскольку теговые объекты всегда передаются по ссылке, вы можете использовать этот вид преобразования для изменения состояния объекта: изменения в преобразованном объекте повлияют на оригинал. (Прим. пер.: Это не так, только преобразование представление позволяет менять оригинал.)

main.adb

1with P; use P;

2

3procedure Main is

4   O1 : Derived := (A => 12);

5   --  Declare an object of type Derived

6

7   O2 : My_Class := My_Class (O1);

8

9   O3 : My_Class'Class := O2;

10begin

11   Foo (O1);

12   --  Non dispatching: Calls Derived.Foo

13   Foo (O2);

14   --  Non dispatching: Calls My_Class.Foo

15

16   Foo (O3);

17   --  Dispatching: Calls My_Class.Foo

18end Main;

Runtime output

In Derived.Foo, A =  12

In My_Class.Foo

In My_Class.Foo

Точечная нотация

Вы также можете вызывать примитивы теговых типов с помощью нотации, более привычной объектно-ориентированным программистам. Учитывая приведенный выше примитив Foo, вы также можете написать указанную выше программу следующим образом:

main.adb

1with P; use P;

2

3procedure Main is

4   O1 : My_Class;

5   --  Declare an object of type My_Class

6

7   O2 : Derived := (A => 12);

8   --  Declare an object of type Derived

9

10   O3 : My_Class'Class := O2;

11

12   O4 : My_Class'Class := O1;

13begin

14   O1.Foo;

15   --  Non dispatching: Calls My_Class.Foo

16   O2.Foo;

17   --  Non dispatching: Calls Derived.Foo

18   O3.Foo;

19   --  Dispatching: Calls Derived.Foo

20   O4.Foo;

21   --  Dispatching: Calls My_Class.Foo

22end Main;

Runtime output

In My_Class.Foo

In Derived.Foo, A =  12

In Derived.Foo, A =  12

In My_Class.Foo

Если диспетчерезирующий параметр примитива является первым параметром, как в наших примерах, вы можете вызвать примитив, используя точечную нотацию. Все оставшиеся параметры передаются обычным образом:

main.adb

1with P; use P;

2

3procedure Main is

4   package Extend is

5      type D2 is new Derived with null record;

6

7      procedure Bar (Self : in out D2;

8                     Val  :        Integer);

9   end Extend;

10

11   package body Extend is

12      procedure Bar (Self : in out D2;

13                     Val  :        Integer) is

14      begin

15         Self.A := Self.A + Val;

16      end Bar;

17   end Extend;

18

19   use Extend;

20

21   Obj : D2 := (A => 15);

22begin

23   Obj.Bar (2);

24   Obj.Foo;

25end Main;

Runtime output

In Derived.Foo, A =  17

Личные и лимитируемые типы с тегами

Ранее мы видели (в главе Изоляция), что типы могут быть объявлены лимитируемыми или личными. Эти методы инкапсуляции также могут применяться к теговым типам, как мы увидим в этом разделе.

Это пример личного тегового типа:

p.ads

1package P is

2   type T is tagged private;

3private

4   type T is tagged record

5       E : Integer;

6   end record;

7end P;

Это пример лимитируемого тегового типа:

p.ads

1package P is

2   type T is tagged limited record

3       E : Integer;

4   end record;

5end P;

Естественно, вы можете комбинировать как лимитируемые, так и личные типы и объявить лимитируемый личный теговый тип:

p.ads

1package P is

2   type T is tagged limited private;

3

4   procedure Init (A : in out T);

5private

6   type T is tagged limited record

7       E : Integer;

8   end record;

9end P;

p.adb

1package body P is

2

3   procedure Init (A : in out T) is

4   begin

5      A.E := 0;

6   end Init;

7

8end P;

main.adb

1with P; use P;

2

3procedure Main is

4  T1, T2 : T;

5begin

6  T1.Init;

7  T2.Init;

8

9  --  The following line doesn't work

10  --  because type T is private:

11  --

12  --  T1.E := 0;

13

14  --  The following line doesn't work

15  --  because type T is limited:

16  --

17  --  T2 := T1;

18end Main;

Обратите внимание, что код в процедуре Main имеет два оператора присваивания, которые вызывают ошибки компиляции, потому что тип T является лимитируемым личным. Фактически, вы не можете:

- присваивать T1.E непосредственно, потому что тип T является личным;

- присваивать T1 в T2, потому что тип T ограничен.

В этом случае нет различия между теговими типами и типами без тегов: эти ошибки компиляции также могут возникать и для нетеговых типов.

Надклассовые ссылочные типы

В этом разделе мы обсудим полезный шаблон для объектно-ориентированного программирования в Аде: надклассовые ссылочные типы. Начнем с примера, в котором мы объявляем теговый тип T и производный тип T_New:

p.ads

1package P is

2   type T is tagged null record;

3

4   procedure Show (Dummy : T);

5

6   type T_New is new T with null record;

7

8   procedure Show (Dummy : T_New);

9end P;

p.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body P is

4

5   procedure Show (Dummy : T) is

6   begin

7      Put_Line ("Using type "

8                & T'External_Tag);

9   end Show;

10

11   procedure Show (Dummy : T_New) is

12   begin

13      Put_Line ("Using type "

14                & T_New'External_Tag);

15   end Show;

16

17end P;

Обратите внимание, как мы используем пустые записи для типов T и T_New. Хотя эти типы на самом деле не имеют каких-либо компонент, мы по-прежнему можем использовать их для демонстрации диспетчеризации. Также обратите внимание, что в приведенном выше примере используется атрибут 'External_Tag в реализации процедуры Show для получения строки с названием соответствующего тегового типа.

Как мы видели ранее, мы должны использовать надклассовый тип для создания объектов, которые могут выполнять диспетчерезируемые вызовы. Другими словами, будут диспетчеризироваться объекты типа T'Class. Например:

dispatching_example.adb

1with P; use P;

2

3procedure Dispatching_Example is

4  T2         :          T_New;

5  T_Dispatch : constant T'Class := T2;

6begin

7  T_Dispatch.Show;

8end Dispatching_Example;

Runtime output

Using type P.T_NEW

Более полезным приложением является объявление массива объектов, для которых будет выполняться диспетчеризация. Например, мы хотели бы объявить массив T_Arr, перебрать в цикле этот массив и выполнить диспетчеризацию в соответствии с фактическим типом каждого отдельного элемента массива:

for I in T_Arr'Range loop

T_Arr (I).Show;

--  Call Show procedure according

--  to actual type of T_Arr (I)

end loop;

Однако непосредственно объявить массив с элементами T'Class невозможно:

classwide_compilation_error.adb

1with P; use P;

2

3procedure Classwide_Compilation_Error is

4  T_Arr  : array (1 .. 2) of T'Class;

5  --                         ^

6  --               Compilation Error!

7begin

8  for I in T_Arr'Range loop

9     T_Arr (I).Show;

10  end loop;

11end Classwide_Compilation_Error;

Build output

classwide_compilation_error.adb:4:31: error: unconstrained element type in array declaration

gprbuild: *** compilation phase failed

В самом деле, компилятор не может знать, какой тип фактически будет использоваться для каждого элемента массива. Но, если мы используем динамическое распределение памяти используя ссылочные типы, мы сможем выделять объекты разных типов для отдельных элементов массива T_Arr. Мы делаем это с помощью надклассовых ссылочных типов, которые имеют следующий формат:

type T_Class is access T'Class;

Мы можем переписать предыдущий пример, используя тип T_Class. В этом случае динамически выделяемые объекты этого типа будут диспетчеризироваться в соответствии с фактическим типом, используемым во время выделения. Также давайте добавим процедуру Init, которая не будет переопределена для производного типа T_New. Это адаптированный код:

p.ads

1package P is

2   type T is tagged record

3       E : Integer;

4   end record;

5

6   type T_Class is access T'Class;

7

8   procedure Init (A : in out T);

9

10   procedure Show (Dummy : T);

11

12   type T_New is new T with null record;

13

14   procedure Show (Dummy : T_New);

15

16end P;

p.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body P is

4

5   procedure Init (A : in out T) is

6   begin

7      Put_Line ("Initializing type T...");

8      A.E := 0;

9   end Init;

10

11   procedure Show (Dummy : T) is

12   begin

13      Put_Line ("Using type "

14                & T'External_Tag);

15   end Show;

16

17   procedure Show (Dummy : T_New) is

18   begin

19      Put_Line ("Using type "

20                & T_New'External_Tag);

21   end Show;

22

23end P;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with P;           use P;

3

4procedure Main is

5  T_Arr  : array (1 .. 2) of T_Class;

6begin

7  T_Arr (1) := new T;

8  T_Arr (2) := new T_New;

9

10  for I in T_Arr'Range loop

11     Put_Line ("Element # "

12               & Integer'Image (I));

13

14     T_Arr (I).Init;

15     T_Arr (I).Show;

16

17     Put_Line ("-----------");

18  end loop;

19end Main;

Runtime output

Element #  1

Initializing type T...

Using type P.T

-----------

Element #  2

Initializing type T...

Using type P.T_NEW

-----------

В этом примере первый элемент (T_Arr (1)) имеет тип T, а второй элемент - тип T_New. При запуске примера процедура Init типа T вызывается для обоих элементов массива T_Arr, в то время, как вызов процедуры Show выберет нужную процедуру в соответствии с типом каждого элемента T_Arr.

Footnotes

#1

https://ru.wikipedia.org/wiki/Динамическая_идентификация_типа_данных

Стандартная библиотека: Контейнеры

В предыдущих главах мы использовали массивы в качестве стандартного способа, который группирует нескольких объектов определенного типа данных. Во многих случаях массивы достаточно хороши для работы с групрой объектов. Однако бывают ситуации, которые требуют большей гибкости и более совершенные операций. Для этих случаев Ада предоставляет поддержку контейнеров - таких как векторы и множества - в своей стандартной библиотеке.

Здесь мы представляем введение в контейнеры. Список всех контейнеров, имеющихся в Аде, см. в Приложении B.

Векторы

В следующих разделах мы представляем общий обзор векторов, включая создание экземпляров, инициализацию и операции с элементами вектора и самими векторами.

Создание экземпляра

Вот пример, показывающий настройку и объявление вектора V:

show_vector_inst.adb

1with Ada.Containers.Vectors;

2

3procedure Show_Vector_Inst is

4

5   package Integer_Vectors is new

6     Ada.Containers.Vectors

7       (Index_Type   => Natural,

8        Element_Type => Integer);

9

10   V : Integer_Vectors.Vector;

11begin

12   null;

13end Show_Vector_Inst;

Build output

show_vector_inst.adb:10:04: warning: variable "V" is not referenced [-gnatwu]

Контейнеры основаны на настраиваемых пакетах, поэтому мы не можем просто объявить вектор, как если бы объявляли массив определенного типа:

A : array (1 .. 10) of Integer;

Вместо этого нам сначала нужно создать экземпляр одного из этих пакетов. Мы используем пакет контейнера (в данном случае Ada.Containers.Vectors) и настраиваем его, чтобы создать экземпляр настраиваемого пакета для желаемого типа. Только затем мы сможем объявить вектор, используя тип из созданного пакета. Такая настройка необходима для любого типа контейнера стандартной библиотеки.

При настройки экземпляра Integer_Vectors мы указываем, что вектор содержит элементы типа Integer, указывая его как Element_Type. Подставляя для Index_Type тип Natural, мы указываем, что допустимый диапазон индекса включает все натуральные числа. При желании мы могли бы использовать более ограниченный диапазон.

Инициализация

Один из способов инициализации вектора - это конкатенация элементов. Мы используем оператор &, как показано в следующем примере:

show_vector_init.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Vector_Init is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   use Integer_Vectors;

14

15   V : Vector := 20 & 10 & 0 & 13;

16begin

17   Put_Line ("Vector has "

18             & Count_Type'Image (V.Length)

19             & " elements");

20end Show_Vector_Init;

Build output

show_vector_init.adb:15:04: warning: "V" is not modified, could be declared constant [-gnatwk]

Runtime output

Vector has  4 elements

Мы указываем use Integer_Vectors, чтобы получить прямой доступ к типам и операциям из созданного пакета. Кроме того, пример знакомит нас с еще одной операцией вектора: Length, она возвращает количество элементов в векторе. Мы можем использовать точечную нотацию, потому что Vector - это теговый тип, и это позволяет нам писать, как V.Length, так и Length (V).

Добавление элементов

Вы добавляете элементы в вектор с помощью операций Prepend и Append. Как следует из названий, эти операции добавляют элементы в начало или конец вектора соответственно. Например:

show_vector_append.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Vector_Append is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   use Integer_Vectors;

14

15   V : Vector;

16begin

17   Put_Line ("Appending some elements to the vector...");

18   V.Append (20);

19   V.Append (10);

20   V.Append (0);

21   V.Append (13);

22   Put_Line ("Finished appending.");

23

24   Put_Line ("Prepending some elements to the vector...");

25   V.Prepend (30);

26   V.Prepend (40);

27   V.Prepend (100);

28   Put_Line ("Finished prepending.");

29

30   Put_Line ("Vector has "

31             & Count_Type'Image (V.Length)

32             & " elements");

33end Show_Vector_Append;

Runtime output

Appending some elements to the vector...

Finished appending.

Prepending some elements to the vector...

Finished prepending.

Vector has  7 elements

В этом примере элементы помещаются в вектор в следующей последовательности: (100, 40, 30, 20, 10, 0, 13).

Справочное руководство указывает, что сложность наихудшего случая должна быть:

- O(log N) для операции Append и

- O(N log N) для операции Prepend.

Доступ к первому и последнему элементам

Мы получаем доступ к первому и последнему элементам вектора с помощью функций First_Element и Last_Element. Например:

show_vector_first_last_element.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Vector_First_Last_Element is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   use Integer_Vectors;

14

15   function Img (I : Integer)    return String

16     renames Integer'Image;

17   function Img (I : Count_Type) return String

18     renames Count_Type'Image;

19

20   V : Vector := 20 & 10 & 0 & 13;

21begin

22   Put_Line ("Vector has "

23             & Img (V.Length)

24             & " elements");

25

26   --  Using V.First_Element to

27   --  retrieve first element

28   Put_Line ("First element is "

29             & Img (V.First_Element));

30

31   --  Using V.Last_Element to

32   --  retrieve last element

33   Put_Line ("Last element is "

34             & Img (V.Last_Element));

35end Show_Vector_First_Last_Element;

Build output

show_vector_first_last_element.adb:20:04: warning: "V" is not modified, could be declared constant [-gnatwk]

Runtime output

Vector has  4 elements

First element is  20

Last element is  13

Вы можете поменять местами элементы с помощью процедуры Swap, передав ей курсоры на первый и последний элементы вектора полученные функциями First и Last. Курсор используются при переборе элементов контейнера и для указания на отдельные его элементы.

С помощью этих операций мы можем написать код, чтобы поменять местами первый и последний элементы вектора:

show_vector_first_last_element.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Vector_First_Last_Element is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   use Integer_Vectors;

14

15   function Img (I : Integer) return String

16     renames Integer'Image;

17

18   V : Vector := 20 & 10 & 0 & 13;

19begin

20   --  We use V.First and V.Last to retrieve

21   --  cursor for first and last elements.

22   --  We use V.Swap to swap elements.

23   V.Swap (V.First, V.Last);

24

25   Put_Line ("First element is now "

26             & Img (V.First_Element));

27   Put_Line ("Last element is now "

28             & Img (V.Last_Element));

29end Show_Vector_First_Last_Element;

Runtime output

First element is now  13

Last element is now  20

Итерация

Самый простой способ перебрать элементы контейнера - использовать цикл for E of Our_Container. Это дает нам ссылку (E) на элемент в текущей позиции. Затем мы можем использовать E непосредственно. Например:

show_vector_iteration.adb

1with Ada.Containers.Vectors;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Vector_Iteration is

6

7   package Integer_Vectors is new

8     Ada.Containers.Vectors

9       (Index_Type   => Natural,

10        Element_Type => Integer);

11

12   use Integer_Vectors;

13

14   function Img (I : Integer) return String

15     renames Integer'Image;

16

17   V : Vector := 20 & 10 & 0 & 13;

18begin

19   Put_Line ("Vector elements are: ");

20

21   --

22   --  Using for ... of loop to iterate:

23   --

24   for E of V loop

25      Put_Line ("- " & Img (E));

26   end loop;

27

28end Show_Vector_Iteration;

Build output

show_vector_iteration.adb:17:04: warning: "V" is not modified, could be declared constant [-gnatwk]

Runtime output

Vector elements are:

-  20

-  10

-  0

-  13

Этот код отображает каждый элемент вектора V.

Поскольку у нас есть ссылка, мы можем отобразить не только значение элемента, но и изменить его. Например, мы могли бы легко записать цикл, чтобы добавить единицу к каждому элементу вектора V:

for E of V loop

E := E + 1;

end loop;

Мы также можем использовать индексы для доступа к элементам вектора. Формат аналогичен циклу по элементам массива: мы используем в цикле for I in <range>. Диапазон строим из V.First_Index и V.Last_Index. Мы можем обратиться к текущему элементу, используя операцию индексирования массива: V (I). Например:

show_vector_index_iteration.adb

1with Ada.Containers.Vectors;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Vector_Index_Iteration is

6

7   package Integer_Vectors is new

8     Ada.Containers.Vectors

9       (Index_Type   => Natural,

10        Element_Type => Integer);

11

12   use Integer_Vectors;

13

14   V : Vector := 20 & 10 & 0 & 13;

15begin

16   Put_Line ("Vector elements are: ");

17

18   --

19   --  Using indices in a "for I in ..." loop

20   --  to iterate:

21   --

22   for I in V.First_Index .. V.Last_Index loop

23      --  Displaying current index I

24      Put ("- ["

25           & Extended_Index'Image (I)

26           & "] ");

27

28      Put (Integer'Image (V (I)));

29

30      --  We could also use the V.Element (I)

31      --  function to retrieve the element at

32      --  the current index I

33

34      New_Line;

35   end loop;

36

37end Show_Vector_Index_Iteration;

Build output

show_vector_index_iteration.adb:14:04: warning: "V" is not modified, could be declared constant [-gnatwk]

Runtime output

Vector elements are:

- [ 0]  20

- [ 1]  10

- [ 2]  0

- [ 3]  13

Здесь, помимо вывода элементов вектора, мы также печатаем каждый индекс I, точно так же, как то, что мы можем сделать для индексов массива. Получить элемент можено, как с помощью краткой формы V (I), так и с помощью вызова функции V.Element (I), но не как V.I.

Как упоминалось в предыдущем разделе, курсоры можно использовать для итерации по контейнерам. Для этого используйте функцию Iterate, которая выдает курсоры для каждой позиции в векторе. Соответствующий цикл имеет формат for C in V.Iterate loop. Как и в предыдущем примере с использованием индексов, можно снова получить доступ к текущему элементу, используя курсор в качестве индекса массива V (C). Например:

show_vector_cursor_iteration.adb

1with Ada.Containers.Vectors;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Vector_Cursor_Iteration is

6

7   package Integer_Vectors is new

8     Ada.Containers.Vectors

9       (Index_Type   => Natural,

10        Element_Type => Integer);

11

12   use Integer_Vectors;

13

14   V : Vector := 20 & 10 & 0 & 13;

15begin

16   Put_Line ("Vector elements are: ");

17

18   --

19   --  Use a cursor to iterate in a loop:

20   --

21   for C in V.Iterate loop

22      --  Using To_Index function to retrieve

23      --  the index for the cursor position

24      Put ("- ["

25           & Extended_Index'Image (To_Index (C))

26           & "] ");

27

28      Put (Integer'Image (V (C)));

29

30      --  We could use Element (C) to retrieve

31      --  the vector element for the cursor

32      --  position

33

34      New_Line;

35   end loop;

36

37   --  Alternatively, we could iterate with a

38   --  while-loop:

39   --

40   --  declare

41   --     C : Cursor := V.First;

42   --  begin

43   --     while C /= No_Element loop

44   --        some processing here...

45   --

46   --        C := Next (C);

47   --     end loop;

48   --  end;

49

50end Show_Vector_Cursor_Iteration;

Build output

show_vector_cursor_iteration.adb:14:04: warning: "V" is not modified, could be declared constant [-gnatwk]

Runtime output

Vector elements are:

- [ 0]  20

- [ 1]  10

- [ 2]  0

- [ 3]  13

Мы также могли бы использовать более длинную форму Element (C), вместо V (C), для доступа к элементу в цикле. В этом примере мы используем функцию To_Index для получения индекса, соответствующего текущему курсору.

Как показано в комментариях после цикла, мы также можем использовать цикл while ... loop для прохода по вектору. В этом случае мы должны начать с курсора первого элемента (полученного с помощью вызова V.First), а затем вызывать Next (C), чтобы получить курсор для последующих элементов. Функция Next (C) возвращает No_Element, когда курсор достигает конца вектора. Используя курсор вы можете изменять элементы вектора непосредственно.

Вот как это выглядит при использовании, как индексов, так и курсоров:

--  Modify vector elements using index

for I in V.First_Index .. V.Last_Index loop

V (I) := V (I) + 1;

end loop;

--  Modify vector elements using cursor

for C in V.Iterate loop

V (C) := V (C) + 1;

end loop;

Справочное руководство требует, чтобы сложность доступа к элементу в наихудшем случае составляла O (log N).

Другой способ изменения элементов вектора - использование процедуры обработки, которая получает отдельный элемент и выполняет над ним некоторую работу. Вы можете вызвать Update_Element, передав курсор и ссулку на процедуру обреботки. Например:

show_vector_update.adb

1with Ada.Containers.Vectors;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Vector_Update is

6

7   package Integer_Vectors is new

8     Ada.Containers.Vectors

9       (Index_Type   => Natural,

10        Element_Type => Integer);

11

12   use Integer_Vectors;

13

14   procedure Add_One (I : in out Integer) is

15   begin

16      I := I + 1;

17   end Add_One;

18

19   V : Vector := 20 & 10 & 12;

20begin

21   --

22   --  Use V.Update_Element to process elements

23   --

24   for C in V.Iterate loop

25      V.Update_Element (C, Add_One'Access);

26   end loop;

27

28end Show_Vector_Update;

Build output

show_vector_update.adb:3:09: warning: no entities of "Ada.Text_IO" are referenced [-gnatwu]

show_vector_update.adb:3:19: warning: use clause for package "Text_IO" has no effect [-gnatwu]

Поиск и изменение элементов

Вы можете найти определенный элемент в векторе и получить его индекс. Функция Find_Index вернет индекс первого элемента, соответствующего искомому значению. В качестве альтернативы вы можете использовать Find, чтобы получить курсор, ссылающийся на этот элемент. Например:

show_find_vector_element.adb

1with Ada.Containers.Vectors;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Find_Vector_Element is

6

7   package Integer_Vectors is new

8     Ada.Containers.Vectors

9       (Index_Type   => Natural,

10        Element_Type => Integer);

11

12   use Integer_Vectors;

13

14   V : Vector := 20 & 10 & 0 & 13;

15   Idx : Extended_Index;

16   C   : Cursor;

17begin

18   --  Using Find_Index to retrieve the index

19   --  of element with value 10

20   Idx := V.Find_Index (10);

21   Put_Line ("Index of element with value 10 is "

22             & Extended_Index'Image (Idx));

23

24   --  Using Find to retrieve the cursor for

25   --  the element with value 13

26   C   := V.Find (13);

27   Idx := To_Index (C);

28   Put_Line ("Index of element with value 13 is "

29             & Extended_Index'Image (Idx));

30end Show_Find_Vector_Element;

Build output

show_find_vector_element.adb:14:04: warning: "V" is not modified, could be declared constant [-gnatwk]

Runtime output

Index of element with value 10 is  1

Index of element with value 13 is  3

Как мы видели в предыдущем разделе, мы можем осуществлять прямой доступ к элементам вектора используя индекс или курсор. Но, если мы пытаемся получить доступ к элементу с недопустимым индексом или курсором, будет возбуждено исключение, поэтому мы сначала должны проверить, действителен ли индекс или курсор, прежде чем использовать его для доступа к элементу. В нашем примере Find_Index или Find могли не найти элемент в векторе. Мы проверяем эту ситуацию, сравнивая индекс с No_Index или курсора с No_Element. Например:

--  Modify vector element using index

if Idx /= No_Index then

V (Idx) := 11;

end if;

--  Modify vector element using cursor

if C /= No_Element then

V (C) := 14;

end if;

Вместо того, чтобы писать V (C) := 14, мы могли бы использовать более длинную форму V.Replace_Element (C, 14).

Вставка элементов

В предыдущих разделах мы видели примеры того, как добавлять элементы в вектор:

- с помощью оператора конкатенации (&) при объявлении вектора, или

- вызвав процедуры Prepend и Append.

Вам может потребоваться вставить элемент в определенное место, например, перед определенным элементом в векторе. Вы делаете это, вызывая Insert. Например:

show_vector_insert.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Vector_Insert is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   use Integer_Vectors;

14

15   procedure Show_Elements (V : Vector) is

16   begin

17      New_Line;

18      Put_Line ("Vector has "

19                & Count_Type'Image (V.Length)

20                & " elements");

21

22      if not V.Is_Empty then

23         Put_Line ("Vector elements are: ");

24         for E of V loop

25            Put_Line ("- " & Integer'Image (E));

26         end loop;

27      end if;

28   end Show_Elements;

29

30   V : Vector := 20 & 10 & 12;

31   C : Cursor;

32begin

33   Show_Elements (V);

34

35   New_Line;

36   Put_Line ("Adding element with value 9 (before 10)...");

37

38   --

39   --  Using V.Insert to insert the element

40   --  into the vector

41   --

42   C := V.Find (10);

43   if C /= No_Element then

44      V.Insert (C, 9);

45   end if;

46

47   Show_Elements (V);

48

49end Show_Vector_Insert;

Runtime output

Vector has  3 elements

Vector elements are:

-  20

-  10

-  12

Adding element with value 9 (before 10)...

Vector has  4 elements

Vector elements are:

-  20

-  9

-  10

-  12

В этом примере мы ищем элемент со значением 10. Если он найден, перед ним вставляется элемент со значением 9.

Удаление элементов

Вы можете удалить элементы из вектора, передав соответствующий индекс или курсор в процедуру удаления Delete. Если мы объединим это с функциями Find_Index и Find из предыдущего раздела, мы сможем написать программу, которая ищет определенный элемент и удаляет его, если он найден:

show_remove_vector_element.adb

1with Ada.Containers.Vectors;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Remove_Vector_Element is

6   package Integer_Vectors is new

7     Ada.Containers.Vectors

8       (Index_Type   => Natural,

9        Element_Type => Integer);

10

11   use Integer_Vectors;

12

13   V : Vector := 20 & 10 & 0 & 13 & 10 & 13;

14   Idx : Extended_Index;

15   C   : Cursor;

16begin

17   --  Use Find_Index to retrieve index of

18   --  the element with value 10

19   Idx := V.Find_Index (10);

20

21   --  Checking whether index is valid

22   if Idx /= No_Index then

23      --  Removing element using V.Delete

24      V.Delete (Idx);

25   end if;

26

27   --  Use Find to retrieve cursor for

28   --  the element with value 13

29   C := V.Find (13);

30

31   --  Check whether index is valid

32   if C /= No_Element then

33      --  Remove element using V.Delete

34      V.Delete (C);

35   end if;

36

37end Show_Remove_Vector_Element;

Build output

show_remove_vector_element.adb:3:09: warning: no entities of "Ada.Text_IO" are referenced [-gnatwu]

show_remove_vector_element.adb:3:19: warning: use clause for package "Text_IO" has no effect [-gnatwu]

Мы можем расширить этот подход, чтобы удалить все элементы, соответствующие определенному значению. Нам просто нужно продолжать поиск элемента в цикле, пока мы не получим недопустимый индекс или курсор. Например:

show_remove_vector_elements.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Remove_Vector_Elements is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   use Integer_Vectors;

14

15   procedure Show_Elements (V : Vector) is

16   begin

17      New_Line;

18      Put_Line ("Vector has "

19                & Count_Type'Image (V.Length)

20                & " elements");

21

22      if not V.Is_Empty then

23         Put_Line ("Vector elements are: ");

24         for E of V loop

25            Put_Line ("- " & Integer'Image (E));

26         end loop;

27      end if;

28   end Show_Elements;

29

30   V : Vector := 20 & 10 & 0 & 13 & 10 & 14 & 13;

31begin

32   Show_Elements (V);

33

34   --

35   --  Remove elements using an index

36   --

37   declare

38      E : constant Integer := 10;

39      I : Extended_Index;

40   begin

41      New_Line;

42      Put_Line ("Removing all elements with value of "

43                & Integer'Image (E) & "...");

44      loop

45         I := V.Find_Index (E);

46         exit when I = No_Index;

47         V.Delete (I);

48      end loop;

49   end;

50

51   --

52   --  Remove elements using a cursor

53   --

54   declare

55      E : constant Integer := 13;

56      C : Cursor;

57   begin

58      New_Line;

59      Put_Line ("Removing all elements with value of "

60                & Integer'Image (E) & "...");

61      loop

62         C := V.Find (E);

63         exit when C = No_Element;

64         V.Delete (C);

65      end loop;

66   end;

67

68   Show_Elements (V);

69end Show_Remove_Vector_Elements;

Runtime output

Vector has  7 elements

Vector elements are:

-  20

-  10

-  0

-  13

-  10

-  14

-  13

Removing all elements with value of  10...

Removing all elements with value of  13...

Vector has  3 elements

Vector elements are:

-  20

-  0

-  14

В этом примере мы удаляем из вектора все элементы со значением 10, получая их индекс. Точно так же мы удаляем все элементы со значением 13 использую курсор.

Другие операции

Мы видели некоторые операции с элементами вектора. Здесь мы продемонстрируем операции с вектором в целом. Наиболее заметным является объединение нескольких векторов, но мы также увидим такие операции с векторами, как сортировка и слияния отсортированных массивов, которые рассматривают вектор, как последовательность элементов, при этом учитывают отношения элементов друг с другом.

Мы выполняем конкатенацию векторов с помощью оператора & для векторов. Рассмотрим два вектора V1 и V2. Мы можем объединить их, выполнив V := V1 & V2. Результирующий вектор содержится в V.

Настраиваемый пакет Generic_Sorting является дочерним пакетом Ada.Containers.Vectors. Он содержит операции сортировки и объединения. Поскольку это настраиваемый пакет, вы не можете использовать его непосредственно, но должны сначала настроить его. Чтобы использовать эти операции с вектором целочисленных значений (Integer_Vectors в нашем примере), вам необходимо настроить пакет дочерний к Integer_Vectors. Следующий пример поясняет, как это сделать.

После настройки Generic_Sorting мы делаем все операции доступными с помощью спецификатора use. Затем мы можем вызвать Sort, чтобы отсортировать вектор, и Merge, чтобы объединить один вектор с другим.

В следующем примере представлен код, который работает тремя векторами (V1, V2, V3) и использует операций конкатенации, сортировки и слияния:

show_vector_ops.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Vectors;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Vector_Ops is

7

8   package Integer_Vectors is new

9     Ada.Containers.Vectors

10       (Index_Type   => Natural,

11        Element_Type => Integer);

12

13   package Integer_Vectors_Sorting is new Integer_Vectors.Generic_Sorting;

14

15   use Integer_Vectors;

16   use Integer_Vectors_Sorting;

17

18   procedure Show_Elements (V : Vector) is

19   begin

20      New_Line;

21      Put_Line ("Vector has "

22                & Count_Type'Image (V.Length)

23                & " elements");

24

25      if not V.Is_Empty then

26         Put_Line ("Vector elements are: ");

27         for E of V loop

28            Put_Line ("- " & Integer'Image (E));

29         end loop;

30      end if;

31   end Show_Elements;

32

33   V, V1, V2, V3 : Vector;

34begin

35   V1 := 10 & 12 & 18;

36   V2 := 11 & 13 & 19;

37   V3 := 15 & 19;

38

39   New_Line;

40   Put_Line ("---- V1 ----");

41   Show_Elements (V1);

42

43   New_Line;

44   Put_Line ("---- V2 ----");

45   Show_Elements (V2);

46

47   New_Line;

48   Put_Line ("---- V3 ----");

49   Show_Elements (V3);

50

51   New_Line;

52   Put_Line ("Concatenating V1, V2 and V3 into V:");

53

54   V := V1 & V2 & V3;

55

56   Show_Elements (V);

57

58   New_Line;

59   Put_Line ("Sorting V:");

60

61   Sort (V);

62

63   Show_Elements (V);

64

65   New_Line;

66   Put_Line ("Merging V2 into V1:");

67

68   Merge (V1, V2);

69

70   Show_Elements (V1);

71

72end Show_Vector_Ops;

Runtime output

---- V1 ----

Vector has  3 elements

Vector elements are:

-  10

-  12

-  18

---- V2 ----

Vector has  3 elements

Vector elements are:

-  11

-  13

-  19

---- V3 ----

Vector has  2 elements

Vector elements are:

-  15

-  19

Concatenating V1, V2 and V3 into V:

Vector has  8 elements

Vector elements are:

-  10

-  12

-  18

-  11

-  13

-  19

-  15

-  19

Sorting V:

Vector has  8 elements

Vector elements are:

-  10

-  11

-  12

-  13

-  15

-  18

-  19

-  19

Merging V2 into V1:

Vector has  6 elements

Vector elements are:

-  10

-  11

-  12

-  13

-  18

-  19

Справочное руководство требует, чтобы худшей сложностью вызова для сортировки Sort было O(Nsup:2) и средняя сложность должна быть лучше, чем O(Nsup:2).

Множества

Множества это другим вид контейнеров. В то время как векторы позволяют вставлять дублирующиеся элементы, множества гарантируют, что дублированных элементов не будет.

В следующих разделах мы рассмотрим операции, которые вы можете выполнять с множествами. Однако, поскольку многие операции с векторами аналогичны тем, которые используются для множеств, мы рассмотрим их здесь лишь кратко. Пожалуйста, обратитесь к разделу о векторах для более подробного обсуждения.

Инициализация и итерация

Чтобы инициализировать множество, вы можете вызвать процедуру Insert. Делая это, вы должны убедиться, что не вставляются повторяющиеся элементы: если вы попытаетесь вставить дубликат, вы получите исключение. Если вы не уверены, что нет дубликатов, вы можете воспользоваться другими вариантами:

- версия Insert, которая возвращает логическое значение, указывающее, была ли вставка успешной;

- процедура Include, которая молча игнорирует любую попытку вставить повторяющийся элемент.

Чтобы перебрать множество, вы можете использовать цикл for E of S, аналогично векторам. Вы получаете ссылку на элемент в множестве.

Посмотрим на пример:

show_set_init.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Ordered_Sets;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Set_Init is

7

8   package Integer_Sets is new

9     Ada.Containers.Ordered_Sets

10       (Element_Type => Integer);

11

12   use Integer_Sets;

13

14   S : Set;

15   --  Same as:  S : Integer_Sets.Set;

16   C : Cursor;

17   Ins : Boolean;

18begin

19   S.Insert (20);

20   S.Insert (10);

21   S.Insert (0);

22   S.Insert (13);

23

24   --  Calling S.Insert(0) now would raise

25   --  Constraint_Error because this element

26   --  is already in the set. We instead call a

27   --  version of Insert that doesn't raise an

28   --  exception but instead returns a Boolean

29   --  indicating the status

30

31   S.Insert (0, C, Ins);

32   if not Ins then

33      Put_Line ("Inserting 0 into set was not successful");

34   end if;

35

36   --  We can also call S.Include instead

37   --  If the element is already present,

38   --  the set remains unchanged

39   S.Include (0);

40   S.Include (13);

41   S.Include (14);

42

43   Put_Line ("Set has "

44             & Count_Type'Image (S.Length)

45             & " elements");

46

47   --

48   --  Iterate over set using for .. of loop

49   --

50   Put_Line ("Elements:");

51   for E of S loop

52       Put_Line ("- " & Integer'Image (E));

53   end loop;

54end Show_Set_Init;

Runtime output

Inserting 0 into set was not successful

Set has  5 elements

Elements:

-  0

-  10

-  13

-  14

-  20

Операции с элементами

В этом разделе мы кратко рассмотрим следующие операции над множествами:

- Delete и Exclude, чтобы удалить элементы;

- Contains и Find, чтобы проверить наличие элементов.

Чтобы удалить элементы, вы вызываете процедуру Delete. Однако, аналогично описанной выше процедуре Insert, Delete возбуждает исключение, если элемент, подлежащий удалению, отсутствует в множестве. Если элемент может отсутствовать в момент удаления и вам не нужна проверка, то вы можете вызвать процедуру Exclude, которая молча игнорирует любую попытку удалить несуществующий элемент.

Функция Contains возвращает логическое значение Boolean, указывающее, содержится ли значение в множестве. Find также ищет элемент в множестве, но возвращает курсор на элемент или No_Element, если элемент не существует. Вы можете использовать любую из этих функций для проверки наличия элементов в множестве.

Давайте рассмотрим пример, в котором используются эти операции:

show_set_element_ops.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Ordered_Sets;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Set_Element_Ops is

7

8   package Integer_Sets is new

9     Ada.Containers.Ordered_Sets

10       (Element_Type => Integer);

11

12   use Integer_Sets;

13

14   procedure Show_Elements (S : Set) is

15   begin

16      New_Line;

17      Put_Line ("Set has "

18                & Count_Type'Image (S.Length)

19                & " elements");

20      Put_Line ("Elements:");

21      for E of S loop

22         Put_Line ("- " & Integer'Image (E));

23      end loop;

24   end Show_Elements;

25

26   S : Set;

27begin

28   S.Insert (20);

29   S.Insert (10);

30   S.Insert (0);

31   S.Insert (13);

32

33   S.Delete (13);

34

35   --  Calling S.Delete (13) again raises

36   --  Constraint_Error because the element

37   --  is no longer present in the set, so

38   --  it can't be deleted. We can call

39   --  V.Exclude instead:

40   S.Exclude (13);

41

42   if S.Contains (20) then

43      Put_Line ("Found element 20 in set");

44   end if;

45

46   --  Alternatively, we could use S.Find

47   --  instead of S.Contains

48   if S.Find (0) /= No_Element then

49      Put_Line ("Found element 0 in set");

50   end if;

51

52   Show_Elements (S);

53end Show_Set_Element_Ops;

Runtime output

Found element 20 in set

Found element 0 in set

Set has  3 elements

Elements:

-  0

-  10

-  20

В дополнение к упорядоченным множествам, используемым в приведенных выше примерах, стандартная библиотека также предлагает хешированные множества. Справочное руководство требует следующей средней сложности каждой операции:

Операции

Ordered_Sets

Hashed_Sets

- Insert

- Include

- Replace

- Delete

- Exclude

- Find

O((log N) 2) или лучше

O(log N)

Подпрограмма с использованием курсора

O(1)

O(1)

Другие операции

Предыдущие разделы в основном касались операций с отдельными элементами множествоа. Но Ада также предоставляет типичные операции над множествами: объединение, пересечение, разность и симметричная разность. В отличие от некоторых векторных операций, которые мы видели раньше (например, слияния - Merge), здесь вы можете использовать общепринятые операторы, такие как -. В следующей таблице перечислены операции и связанный с ними оператор:

Операции над множеством

Оператор

Объединение

or

Пересечение

and

Разность

-

Симметричная разность

xor

В следующем примере используются эти операторы:

show_set_ops.adb

1with Ada.Containers; use Ada.Containers;

2with Ada.Containers.Ordered_Sets;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Set_Ops is

7

8   package Integer_Sets is new

9     Ada.Containers.Ordered_Sets

10       (Element_Type => Integer);

11

12   use Integer_Sets;

13

14   procedure Show_Elements (S : Set) is

15   begin

16      Put_Line ("Elements:");

17      for E of S loop

18         Put_Line ("- " & Integer'Image (E));

19      end loop;

20   end Show_Elements;

21

22   procedure Show_Op (S       : Set;

23                      Op_Name : String) is

24   begin

25      New_Line;

26      Put_Line (Op_Name

27                & "(set #1, set #2) has "

28                & Count_Type'Image (S.Length)

29                & " elements");

30   end Show_Op;

31

32   S1, S2, S3 : Set;

33begin

34   S1.Insert (0);

35   S1.Insert (10);

36   S1.Insert (13);

37

38   S2.Insert (0);

39   S2.Insert (10);

40   S2.Insert (14);

41

42   S3.Insert (0);

43   S3.Insert (10);

44

45   New_Line;

46   Put_Line ("---- Set #1 ----");

47   Show_Elements (S1);

48

49   New_Line;

50   Put_Line ("---- Set #2 ----");

51   Show_Elements (S2);

52

53   New_Line;

54   Put_Line ("---- Set #3 ----");

55   Show_Elements (S3);

56

57   New_Line;

58   if S3.Is_Subset (S1) then

59      Put_Line ("S3 is a subset of S1");

60   else

61      Put_Line ("S3 is not a subset of S1");

62   end if;

63

64   S3 := S1 and S2;

65   Show_Op (S3, "Intersection");

66   Show_Elements (S3);

67

68   S3 := S1 or S2;

69   Show_Op (S3, "Union");

70   Show_Elements (S3);

71

72   S3 := S1 - S2;

73   Show_Op (S3, "Difference");

74   Show_Elements (S3);

75

76   S3 := S1 xor S2;

77   Show_Op (S3, "Symmetric difference");

78   Show_Elements (S3);

79

80end Show_Set_Ops;

Runtime output

---- Set #1 ----

Elements:

-  0

-  10

-  13

---- Set #2 ----

Elements:

-  0

-  10

-  14

---- Set #3 ----

Elements:

-  0

-  10

S3 is a subset of S1

Intersection(set #1, set #2) has  2 elements

Elements:

-  0

-  10

Union(set #1, set #2) has  4 elements

Elements:

-  0

-  10

-  13

-  14

Difference(set #1, set #2) has  1 elements

Elements:

-  13

Symmetric difference(set #1, set #2) has  2 elements

Elements:

-  13

-  14

Отображения для неопределенных типов

В предыдущих разделах были представлены контейнеры для элементов определенных типов. Хотя большинство примеров в этих разделах использовали целочисленный тип Integer как тип элемента контейнера, контейнеры также могут использоваться с неопределенными типами, примером которых является тип String. Однако неопределенные типы требуют другого вида контейнеров, разработанных специально для них.

Мы также изучим другой класс контейнеров: отображения. Они связывают ключ с определенным значением. Примером отображения является связь «один к одному» между человеком и его возрастом. Если мы считаем имя человека ключевым, то значение - возраст человека.

Хэшированные отображения

Хэшированные отображения - это отображения, которые используют хэш ключа. Сам хэш вычисляется с помощью предоставленной вами функции.

На других языках

Хэшированные отображения похожи на словари в Python и хэши в Perl. Одно из основных отличий заключается в том, что эти скриптовые языки позволяют использовать разные типы для значений, содержащихся в одном отображении, в то время как в Аде, тип ключа и тип значение указываются в настройке пакета и остаются постоянными для этого конкретного отображения. У вас не может быть отображения, содержащего два элемента или два ключа разног типов. Если вы хотите использовать несколько типов, вы должны создать разные отображения для каждого и использовать только одино из них.

При создании настройке хешированного отображения Ada.Containers.Indefinite_Hashed_Maps мы указываем следующие элементы:

- Key_Type: тип ключа

- Element_Type: тип элемента

- HashKey_Type

- Equivalent_Keys: оператор равенства (например, =), который указывает, должны ли два ключа считаться равными.

- Если тип, указанный в Key_Type, имеет стандартный оператор, вы можете использовать его. В примере мы так и делаем. Мы указываем этот оператор как значение Equivalent_Keys.

В следующем примере мы будем использовать строку в качестве типа ключа. Мы будем использовать функцию Hash, предоставляемую стандартной библиотекой для строк (в пакете Ada.Strings), и стандартный оператор равенства.

Вы добавляете элементы в хешированное отображение, вызывая Insert. Если элемент уже содержится в отображении M, вы можете получить к нему доступ непосредственно, используя его ключ. Например, вы можете изменить значение элемента, написав M ("My_Key") := 10. Если ключ не найден, возбуждается исключение. Чтобы проверить, доступен ли ключ, используйте функцию Contains (как мы видели выше в разделе о множествоах).

Посмотрим на пример:

show_hashed_map.adb

1with Ada.Containers.Indefinite_Hashed_Maps;

2with Ada.Strings.Hash;

3

4with Ada.Text_IO; use Ada.Text_IO;

5

6procedure Show_Hashed_Map is

7

8   package Integer_Hashed_Maps is new

9     Ada.Containers.Indefinite_Hashed_Maps

10       (Key_Type        => String,

11        Element_Type    => Integer,

12        Hash            => Ada.Strings.Hash,

13        Equivalent_Keys => "=");

14

15   use Integer_Hashed_Maps;

16

17   M : Map;

18   --  Same as:

19   --

20   --  M : Integer_Hashed_Maps.Map;

21begin

22   M.Include ("Alice", 24);

23   M.Include ("John",  40);

24   M.Include ("Bob",   28);

25

26   if M.Contains ("Alice") then

27      Put_Line ("Alice's age is "

28                & Integer'Image (M ("Alice")));

29   end if;

30

31   --  Update Alice's age

32   --  Key must already exist in M.

33   --  Otherwise an exception is raised.

34   M ("Alice") := 25;

35

36   New_Line; Put_Line ("Name & Age:");

37   for C in M.Iterate loop

38      Put_Line (Key (C) & ": "

39                & Integer'Image (M (C)));

40   end loop;

41

42end Show_Hashed_Map;

Runtime output

Alice's age is  24

Name & Age:

John:  40

Bob:  28

Alice:  25

Упорядоченные отображения

Упорядоченные отображения имеют много общих черт с хэшированными отображениями. Основными отличиями являются:

- Хэш-функция не нужна. Вместо этого вы должны предоставить функцию сравнения (< operator), которую упорядоченное отображение будет использовать для сравнения элементов и обеспечения быстрого доступа (сложность O(log N)), используя двоичный поиск.

- Если тип, указанный в Key_Type, имеет стандартный оператор <, вы можете использовать его аналогично тому, как мы это делали для Equivalent_Keys выше для хэшированных отображений.

Давайте посмотрим на пример:

show_ordered_map.adb

1with Ada.Containers.Indefinite_Ordered_Maps;

2

3with Ada.Text_IO; use Ada.Text_IO;

4

5procedure Show_Ordered_Map is

6

7   package Integer_Ordered_Maps is new

8     Ada.Containers.Indefinite_Ordered_Maps

9       (Key_Type        => String,

10        Element_Type    => Integer);

11

12   use Integer_Ordered_Maps;

13

14   M : Map;

15begin

16   M.Include ("Alice", 24);

17   M.Include ("John",  40);

18   M.Include ("Bob",   28);

19

20   if M.Contains ("Alice") then

21      Put_Line ("Alice's age is "

22                & Integer'Image (M ("Alice")));

23   end if;

24

25   --  Update Alice's age

26   --  Key must already exist in M

27   M ("Alice") := 25;

28

29   New_Line; Put_Line ("Name & Age:");

30   for C in M.Iterate loop

31      Put_Line (Key (C) & ": "

32                & Integer'Image (M (C)));

33   end loop;

34

35end Show_Ordered_Map;

Runtime output

Alice's age is  24

Name & Age:

Alice:  25

Bob:  28

John:  40

Вы можете увидеть большое сходство между примерами, приведенными выше, и примерами из предыдущего раздела. Фактически, поскольку оба типа отображений имеют много общих операций, нам не нужно было вносить существенные изменения, когда мы изменили наш пример, чтобы использовать упорядоченные отображения вместо хешированных. Основное различие видно, когда мы запускаем примеры: вывод для хешированных отображений обычно неупорядочен, но вывод для упорядоченных отображений всегда упорядочен, как следует из его имени.

Сложность

Хэшированные отображения, как правило, являются самой быстрой структурой данных, доступной в Аде, если необходимо связать неоднородные ключи со значениями и быстро находить их. В большинстве случаев они немного быстрее упорядоченных отображений. Так что, если вам не важен порядок, используйте хэшированные отображения.

Справочное руководство требует следующей средней сложности операций:

Операции

Ordered_Maps

Hashed_Maps

- Insert

- Include

- Replace

- Delete

- Exclude

- Find

O((log N) 2) or better

O(log N)

Подпрограмма с использованием курсора

O(1)

O(1)

Footnotes

Стандартная библиотека: Дата и время

Стандартная библиотека поддерживает обработку дат и времени с использованием двух подходов:

- Календарный подход, подходящий для обработки дат и времени в целом;

- Подход реального времени, который лучше подходит для приложений реального времени, требующих повышенной точности, например, благодаря доступу к абсолютным часам и обработке интервалов времени. Следует отметить, что этот подход поддерживает только время, но не даты.

Эти два подхода представлены в следующих разделах.

Обработка даты и времени

Пакет Ada.Calendar поддерживает обработку дат и времени. Рассмотрим простой пример:

display_current_time.adb

1with Ada.Calendar;            use Ada.Calendar;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3with Ada.Text_IO;             use Ada.Text_IO;

4

5procedure Display_Current_Time is

6   Now : Time := Clock;

7begin

8   Put_Line ("Current time: " & Image (Now));

9end Display_Current_Time;

Build output

display_current_time.adb:6:04: warning: "Now" is not modified, could be declared constant [-gnatwk]

Runtime output

Current time: 2022-08-22 21:14:24

В этом примере отображаются текущая дата и время, которые извлекаются при вызове функции Clock. Мы вызываем функцию Image из пакета Ada.Calendar.Formatting, чтобы получить строку (String) для текущей даты и времени. Вместо этого мы могли бы получить каждую компоненту с помощью функции Split. Например:

display_current_year.adb

1with Ada.Calendar;            use Ada.Calendar;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4procedure Display_Current_Year is

5   Now         : Time := Clock;

6

7   Now_Year    : Year_Number;

8   Now_Month   : Month_Number;

9   Now_Day     : Day_Number;

10   Now_Seconds : Day_Duration;

11begin

12   Split (Now,

13          Now_Year,

14          Now_Month,

15          Now_Day,

16          Now_Seconds);

17

18   Put_Line ("Current year  is: "

19             & Year_Number'Image (Now_Year));

20   Put_Line ("Current month is: "

21             & Month_Number'Image (Now_Month));

22   Put_Line ("Current day   is: "

23             & Day_Number'Image (Now_Day));

24end Display_Current_Year;

Build output

display_current_year.adb:5:04: warning: "Now" is not modified, could be declared constant [-gnatwk]

Runtime output

Current year  is:  2022

Current month is:  8

Current day   is:  22

Здесь мы получаем каждый элемент и отображаем его отдельно.

Задержка с использованием даты

Вы можете приостановить приложение, чтобы оно перезапустилось в определенную дату и время. Мы видели нечто подобное в главе о задачах. Вы делаете это с помощью оператора delay until. Например:

display_delay_next_specific_time.adb

1with Ada.Calendar;            use Ada.Calendar;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones;

4with Ada.Text_IO;             use Ada.Text_IO;

5

6procedure Display_Delay_Next_Specific_Time is

7   TZ   : Time_Offset := UTC_Time_Offset;

8   Next : Time        :=

9     Ada.Calendar.Formatting.Time_Of

10       (Year        => 2018,

11        Month       => 5,

12        Day         => 1,

13        Hour        => 15,

14        Minute      => 0,

15        Second      => 0,

16        Sub_Second  => 0.0,

17        Leap_Second => False,

18        Time_Zone   => TZ);

19

20   --  Next = 2018-05-01 15:00:00.00

21   --         (local time-zone)

22begin

23   Put_Line ("Let's wait until...");

24   Put_Line (Image (Next, True, TZ));

25

26   delay until Next;

27

28   Put_Line ("Enough waiting!");

29end Display_Delay_Next_Specific_Time;

Build output

display_delay_next_specific_time.adb:7:04: warning: "TZ" is not modified, could be declared constant [-gnatwk]

display_delay_next_specific_time.adb:8:04: warning: "Next" is not modified, could be declared constant [-gnatwk]

Runtime output

Let's wait until...

2018-05-01 15:00:00.00

Enough waiting!

В этом примере мы указываем дату и время, инициализируя Next с помощью вызова Time_Of, функции, принимающей различные компоненты даты (год, месяц и т. д.) и возвращающей элемент типа Time. Поскольку указанная дата находится в прошлом, задержка delay until не даст заметного эффекта. Если мы укажем дату в будущем, программа будет ждать наступления этой конкретной даты и времени.

Здесь мы переводим время в местный часовой пояс. Если мы не указываем часовой пояс, по умолчанию используется всемирное координированное время (Coordinated Universal Time сокращенно UTC). Получив смещение времени к UTC с помощью вызова UTC_Time_Offset из пакета Ada.Calendar.Time_Zones, мы можем инициализировать TZ и использовать его при вызове Time_Of. Это все, что нам нужно сделать, чтобы информация, предоставляемая Time_Of, относилась к местному часовому поясу.

Мы могли бы добиться аналогичного результата, инициализировав Next с помощью значения типа String. Мы можем сделать это использовав вызов Value из пакета Ada.Calendar.Formatting. Вот модифицированный код:

display_delay_next_specific_time.adb

1with Ada.Calendar;            use Ada.Calendar;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones;

4with Ada.Text_IO;             use Ada.Text_IO;

5

6procedure Display_Delay_Next_Specific_Time is

7   TZ   : Time_Offset := UTC_Time_Offset;

8   Next : Time        :=

9     Ada.Calendar.Formatting.Value

10       ("2018-05-01 15:00:00.00", TZ);

11

12   --  Next = 2018-05-01 15:00:00.00

13   --         (local time-zone)

14begin

15   Put_Line ("Let's wait until...");

16   Put_Line (Image (Next, True, TZ));

17

18   delay until Next;

19

20   Put_Line ("Enough waiting!");

21end Display_Delay_Next_Specific_Time;

Build output

display_delay_next_specific_time.adb:7:04: warning: "TZ" is not modified, could be declared constant [-gnatwk]

display_delay_next_specific_time.adb:8:04: warning: "Next" is not modified, could be declared constant [-gnatwk]

Runtime output

Let's wait until...

2018-05-01 15:00:00.00

Enough waiting!

В этом примере мы снова используем TZ в вызове Value, чтобы привести время ввода в соответствие с текущим часовым поясом.

В приведенных выше примерах мы приостанавливались до определенной даты и времени. Как мы видели в главе о задачах, мы могли бы вместо этого указать задержку относительно текущего времени. Например, мы можем задержать на 5 секунд, используя текущее время:

display_delay_next.adb

1with Ada.Calendar;            use Ada.Calendar;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4procedure Display_Delay_Next is

5   D    : Duration := 5.0;

6   --                 ^ seconds

7   Now  : Time     := Clock;

8   Next : Time     := Now + D;

9   --                       ^ use duration to

10   --                         specify next point

11   --                         in time

12begin

13   Put_Line ("Let's wait "

14             & Duration'Image (D) & " seconds...");

15   delay until Next;

16   Put_Line ("Enough waiting!");

17end Display_Delay_Next;

Build output

display_delay_next.adb:5:04: warning: "D" is not modified, could be declared constant [-gnatwk]

display_delay_next.adb:7:04: warning: "Now" is not modified, could be declared constant [-gnatwk]

display_delay_next.adb:8:04: warning: "Next" is not modified, could be declared constant [-gnatwk]

Runtime output

Let's wait  5.000000000 seconds...

Enough waiting!

Здесь мы указываем продолжительность 5 секунд в D, добавляем ее к текущему времени из Now и сохраняем сумму в Next. Затем мы используем его в операторе delay until.

Режим реального времени

В дополнение к Ada.Calendar стандартная библиотека также поддерживает операции со временем для приложений реального времени. Они включены в пакет Ada.Real_Time. Этот пакет также включает тип Time. Однако в пакете Ada.Real_Time тип Time используется для представления абсолютных часов и обработки промежутков времени. Это контрастирует с Ada.Calendar, который использует тип Time для представления даты и времени.

В предыдущем разделе мы использовали тип Time из Ada.Calendar и оператор delay until, чтобы отложить приложение на 5 секунд. Вместо этого мы могли бы использовать пакет Ada.Real_Time. Давайте изменим этот пример:

display_delay_next_real_time.adb

1with Ada.Text_IO;   use Ada.Text_IO;

2with Ada.Real_Time; use Ada.Real_Time;

3

4procedure Display_Delay_Next_Real_Time is

5   D     : Time_Span := Seconds (5);

6   Next  : Time      := Clock + D;

7begin

8   Put_Line ("Let's wait "

9             & Duration'Image (To_Duration (D))

10             & " seconds...");

11   delay until Next;

12   Put_Line ("Enough waiting!");

13end Display_Delay_Next_Real_Time;

Build output

display_delay_next_real_time.adb:5:04: warning: "D" is not modified, could be declared constant [-gnatwk]

display_delay_next_real_time.adb:6:04: warning: "Next" is not modified, could be declared constant [-gnatwk]

Runtime output

Let's wait  5.000000000 seconds...

Enough waiting!

Основное отличие состоит в том, что D теперь является переменной типа Time_Span, определенной в пакете Ada.Real_Time. Мы вызываем функцию Seconds для инициализации D, но мы могли бы получить более тончное значение, вызвав вместо этого Nanoseconds. Кроме того, нам нужно сначала преобразовать D в тип Duration с помощью функции To_Duration, прежде чем мы сможем его напечатать.

Анализ производительности

Одним из интересных приложений, использующих пакет Ada.Real_Time, является анализ производительности. Мы уже использовали этот пакет в предыдущем разделе при обсуждении задач. Давайте рассмотрим пример анализа производительности:

display_benchmarking.adb

1with Ada.Text_IO;   use Ada.Text_IO;

2with Ada.Real_Time; use Ada.Real_Time;

3

4procedure Display_Benchmarking is

5

6   procedure Computational_Intensive_App is

7   begin

8      delay 5.0;

9   end Computational_Intensive_App;

10

11   Start_Time, Stop_Time : Time;

12   Elapsed_Time          : Time_Span;

13

14begin

15   Start_Time := Clock;

16

17   Computational_Intensive_App;

18

19   Stop_Time    := Clock;

20   Elapsed_Time := Stop_Time - Start_Time;

21

22   Put_Line ("Elapsed time: "

23             & Duration'Image (To_Duration (Elapsed_Time))

24             & " seconds");

25end Display_Benchmarking;

Runtime output

Elapsed time:  5.007097508 seconds

В этом примере определяется фиктивное приложение Computational_Intensive_App, реализованное с использованием простого оператора задержки delay. Мы инициализируем Start_Time и Stop_Time по текущим на тот момент часам и вычисляем прошедшее время. Запустив эту программу, мы видим, что время составляет примерно 5 секунд, что соответствует реботе оператора задержки delay.

Аналогичное приложение - это анализ затраченного процессорного времени. Мы можем реализовать это с помощью пакета Execution_Time. Давайте изменим предыдущий пример, чтобы измерить процессорное время:

display_benchmarking_cpu_time.adb

1with Ada.Text_IO;        use Ada.Text_IO;

2with Ada.Real_Time;      use Ada.Real_Time;

3with Ada.Execution_Time; use Ada.Execution_Time;

4

5procedure Display_Benchmarking_CPU_Time is

6

7   procedure Computational_Intensive_App is

8   begin

9      delay 5.0;

10   end Computational_Intensive_App;

11

12   Start_Time, Stop_Time : CPU_Time;

13   Elapsed_Time          : Time_Span;

14

15begin

16   Start_Time := Clock;

17

18   Computational_Intensive_App;

19

20   Stop_Time    := Clock;

21   Elapsed_Time := Stop_Time - Start_Time;

22

23   Put_Line ("CPU time: "

24             & Duration'Image (To_Duration (Elapsed_Time))

25             & " seconds");

26end Display_Benchmarking_CPU_Time;

Runtime output

CPU time:  0.000125123 seconds

В этом примере Start_Time и Stop_Time имеют тип CPU_Time вместо Time. Однако мы по-прежнему вызываем функцию Clock для инициализации обеих переменных и вычисления прошедшего времени так же, как и раньше. Запустив эту программу, мы видим, что время процессора значительно ниже, чем те 5 секунд, которые мы видели раньше. Это связано с тем, что оператор задержки delay не требует много времени процессора. Результаты будут другими, если мы изменим реализацию Computational_Intensive_App для использования математических функций в длинном цикле. Например:

display_benchmarking_math.adb

1with Ada.Text_IO;        use Ada.Text_IO;

2with Ada.Real_Time;      use Ada.Real_Time;

3with Ada.Execution_Time; use Ada.Execution_Time;

4

5with Ada.Numerics.Generic_Elementary_Functions;

6

7procedure Display_Benchmarking_Math is

8

9   procedure Computational_Intensive_App is

10      package Funcs is new Ada.Numerics.Generic_Elementary_Functions

11        (Float_Type => Long_Long_Float);

12      use Funcs;

13

14      X : Long_Long_Float;

15   begin

16      for I in 0 .. 1_000_000 loop

17         X := Tan (Arctan

18                   (Tan (Arctan

19                      (Tan (Arctan

20                         (Tan (Arctan

21                            (Tan (Arctan

22                               (Tan (Arctan

23                                  (0.577))))))))))));

24      end loop;

25   end Computational_Intensive_App;

26

27   procedure Benchm_Elapsed_Time is

28      Start_Time, Stop_Time : Time;

29      Elapsed_Time          : Time_Span;

30

31   begin

32      Start_Time := Clock;

33

34      Computational_Intensive_App;

35

36      Stop_Time    := Clock;

37      Elapsed_Time := Stop_Time - Start_Time;

38

39      Put_Line ("Elapsed time: "

40                & Duration'Image (To_Duration (Elapsed_Time))

41                & " seconds");

42   end Benchm_Elapsed_Time;

43

44   procedure Benchm_CPU_Time is

45      Start_Time, Stop_Time : CPU_Time;

46      Elapsed_Time          : Time_Span;

47

48   begin

49      Start_Time := Clock;

50

51      Computational_Intensive_App;

52

53      Stop_Time    := Clock;

54      Elapsed_Time := Stop_Time - Start_Time;

55

56      Put_Line ("CPU time: "

57                & Duration'Image (To_Duration (Elapsed_Time))

58                & " seconds");

59   end Benchm_CPU_Time;

60begin

61   Benchm_Elapsed_Time;

62   Benchm_CPU_Time;

63end Display_Benchmarking_Math;

Build output

display_benchmarking_math.adb:14:07: warning: variable "X" is assigned but never read [-gnatwm]

Runtime output

Elapsed time:  0.871429605 seconds

CPU time:  0.876544727 seconds

Теперь, когда наша фиктивная Computational_Intensive_App включает математические операции, требующие значительного времени ЦПУ, измеренное затраченное время и время ЦПУ намного ближе друг к другу, чем раньше.

Footnotes

Стандартная библиотека: Строки

В предыдущих главах мы видели примеры исходного кода с использованием типа String, который является строковым типом фиксированной длины - по сути, это массив символов. Во многих случаях этого типа данных достаточно для работы с текстовой информацией. Однако бывают ситуации, когда требуется более сложная обработка текста. Ада предлагает альтернативные подходы для этих случаев:

- Ограниченные строки: аналогично строкам фиксированной длины, ограниченные строки имеют максимальную длину, которая устанавливается при их создании. Однако ограниченные строки не являются массивами символов. В любой момент они могут содержать строку различной длины - при условии, что эта длина меньше или равна максимальной длине.

- Неограниченные строки: подобно ограниченным строкам, неограниченные строки могут содержать строки различной длины. Однако, помимо этого, у них нет максимальной длины. В этом смысле они очень гибкие.

В следующих разделах представлен обзор различных типов строк и общих операций для типов строк.

Операции со строками

Операции со стандартными строками (фиксированной длины) доступны в пакете Ada.Strings.Fixed. Как упоминалось ранее, стандартные строки представляют собой массивы элементов типа Character с фиксированной длиной. Вот почему этот дочерний пакет называется фиксированным (Fixed).

Одна из самых простых операций - это подсчет количества подстрок, доступных в строке (Count), и поиск их соответствующих индексов (Index). Давайте посмотрим на пример:

show_find_substring.adb

1with Ada.Strings.Fixed; use Ada.Strings.Fixed;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4procedure Show_Find_Substring is

5

6   S   : String := "Hello" & 3 * " World";

7   P   : constant String := "World";

8   Idx : Natural;

9   Cnt : Natural;

10begin

11   Cnt := Ada.Strings.Fixed.Count

12     (Source  => S,

13      Pattern => P);

14

15   Put_Line ("String: " & S);

16   Put_Line ("Count for '" & P & "': "

17             & Natural'Image (Cnt));

18

19   Idx := 0;

20   for I in 1 .. Cnt loop

21      Idx := Index

22        (Source  => S,

23         Pattern => P,

24         From    => Idx + 1);

25

26      Put_Line ("Found instance of '"

27                & P & "' at position: "

28                & Natural'Image (Idx));

29   end loop;

30

31end Show_Find_Substring;

Build output

show_find_substring.adb:6:04: warning: "S" is not modified, could be declared constant [-gnatwk]

Runtime output

String: Hello World World World

Count for 'World':  3

Found instance of 'World' at position:  7

Found instance of 'World' at position:  13

Found instance of 'World' at position:  19

Мы инициализируем строку S умножением. Запись "Hello" & 3 * " World" создает строку Hello World World World. Затем мы вызываем функцию Count, чтобы получить количество экземпляров слова World в S .Затем мы вызываем функцию Index в цикле, чтобы найти индекс каждого экземпляра слова World в S.

В этом примере искались вхождения определенной подстроки. В следующем примере мы извлекаем все слова в строке. Мы делаем это с помощью Find_Token, определив пробелы в качестве разделителей. Например:

show_find_words.adb

1with Ada.Strings;       use Ada.Strings;

2with Ada.Strings.Fixed; use Ada.Strings.Fixed;

3with Ada.Strings.Maps;  use Ada.Strings.Maps;

4with Ada.Text_IO;       use Ada.Text_IO;

5

6procedure Show_Find_Words is

7

8   S   : String := "Hello" & 3 * " World";

9   F   : Positive;

10   L   : Natural;

11   I   : Natural := 1;

12

13   Whitespace : constant Character_Set :=

14     To_Set (' ');

15begin

16   Put_Line ("String: " & S);

17   Put_Line ("String length: "

18             & Integer'Image (S'Length));

19

20   while I in S'Range loop

21      Find_Token

22        (Source  => S,

23         Set     => Whitespace,

24         From    => I,

25         Test    => Outside,

26         First   => F,

27         Last    => L);

28

29      exit when L = 0;

30

31      Put_Line ("Found word instance at position "

32                & Natural'Image (F)

33                & ": '" & S (F .. L) & "'");

34      --   & "-" & F'Img & "-" & L'Img

35

36      I := L + 1;

37   end loop;

38end Show_Find_Words;

Build output

show_find_words.adb:8:04: warning: "S" is not modified, could be declared constant [-gnatwk]

Runtime output

String: Hello World World World

String length:  23

Found word instance at position  1: 'Hello'

Found word instance at position  7: 'World'

Found word instance at position  13: 'World'

Found word instance at position  19: 'World'

Мы передаем множество символов, которые будут использоваться в качестве разделителей для процедуры Find_Token. Это множество является значением типа Character_Set из пакета Ada.Strings.Maps. Мы вызываем функцию To_Set (из того же пакета), чтобы инициализировать множество Whitespace, а затем вызываем Find_Token, чтобы перебрать все возможные индексы и найти начальный индекс каждого слова. Мы передаем Outside в параметр Test процедуры Find_Token, чтобы указать, что мы ищем индексы, которые находятся за пределами множества Whitespace, то есть фактические слова. First и Last параметры Find_Token являются выходными параметрами, которые указывают допустимый диапазон подстроки. Мы используем эту информацию для отображения строки (S (F .. L)).

Операции, которые мы рассмотрели до сих пор, читают строки, но не изменяют их. Далее мы обсудим операции, которые изменяют содержимое строк:

Operation

Description

Insert

Вставка подстроки в строку

Overwrite

Замена подстроки в строке

Delete

Удаление подстроки

Trim

Удаление пробелов из строки

Все эти операции доступны как в виде функций, так и в виде процедур. Функции создают новую строку, но процедуры выполняют операции по месту. Процедура вызовет исключение, если ограничения строки будут нарушены. Например, если у нас есть строка S, содержащая 10 символов, вставка в нее строки с двумя символами (например, "!!") дает строку, содержащую 12 символов. Поскольку она имеет фиксированную длину, мы не можем увеличить его размер. Одно из возможных решений в этом случае - указать, что при вставке подстроки следует применять усечение. Это сохраняет длину S. Давайте посмотрим на пример, в котором используются как функции, так и версии процедур Insert, Overwrite и Delete:

show_adapted_strings.adb

1with Ada.Strings;       use Ada.Strings;

2with Ada.Strings.Fixed; use Ada.Strings.Fixed;

3with Ada.Text_IO;       use Ada.Text_IO;

4

5procedure Show_Adapted_Strings is

6

7   S   : String := "Hello World";

8   P   : constant String := "World";

9   N   : constant String := "Beautiful";

10

11   procedure Display_Adapted_String

12     (Source   : String;

13      Before   : Positive;

14      New_Item : String;

15      Pattern  : String)

16   is

17      S_Ins_In : String := Source;

18      S_Ovr_In : String := Source;

19      S_Del_In : String := Source;

20

21      S_Ins : String :=

22        Insert (Source,

23                Before,

24                New_Item & " ");

25      S_Ovr : String :=

26        Overwrite (Source,

27                   Before,

28                   New_Item);

29      S_Del : String :=

30        Trim (Delete (Source,

31                      Before,

32                      Before + Pattern'Length - 1),

33              Ada.Strings.Right);

34   begin

35      Insert (S_Ins_In,

36              Before,

37              New_Item,

38              Right);

39

40      Overwrite (S_Ovr_In,

41                 Before,

42                 New_Item,

43                 Right);

44

45      Delete (S_Del_In,

46              Before,

47              Before + Pattern'Length - 1);

48

49      Put_Line ("Original:  '"

50                & Source & "'");

51

52      Put_Line ("Insert:    '"

53                & S_Ins  & "'");

54      Put_Line ("Overwrite: '"

55                & S_Ovr  & "'");

56      Put_Line ("Delete:    '"

57                & S_Del  & "'");

58

59      Put_Line ("Insert    (in-place): '"

60                & S_Ins_In & "'");

61      Put_Line ("Overwrite (in-place): '"

62                & S_Ovr_In & "'");

63      Put_Line ("Delete    (in-place): '"

64                & S_Del_In & "'");

65   end Display_Adapted_String;

66

67   Idx : Natural;

68begin

69   Idx := Index

70     (Source  => S,

71      Pattern => P);

72

73   if Idx > 0 then

74      Display_Adapted_String (S, Idx, N, P);

75   end if;

76end Show_Adapted_Strings;

Build output

show_adapted_strings.adb:7:04: warning: "S" is not modified, could be declared constant [-gnatwk]

show_adapted_strings.adb:21:07: warning: "S_Ins" is not modified, could be declared constant [-gnatwk]

show_adapted_strings.adb:25:07: warning: "S_Ovr" is not modified, could be declared constant [-gnatwk]

show_adapted_strings.adb:29:07: warning: "S_Del" is not modified, could be declared constant [-gnatwk]

Runtime output

Original:  'Hello World'

Insert:    'Hello Beautiful World'

Overwrite: 'Hello Beautiful'

Delete:    'Hello'

Insert    (in-place): 'Hello Beaut'

Overwrite (in-place): 'Hello Beaut'

Delete    (in-place): 'Hello      '

В этом примере мы ищем индекс подстроки World и выполняем операции с этой подстрокой внутри внешней строки. Процедура Display_Adapted_String использует обе версии операций. Для процедурной версии Insert и Overwrite мы применяем усечение к правой стороне строки (Right). Для процедуры Delete мы указываем диапазон подстроки, которая заменяется пробелами. Для функциональной версии Delete мы также вызываем Trim. Эта функция которая обрезает конечные пробелы.

Ограничение строк фиксированной длины

Использование строк фиксированной длины обычно достаточно хорошо для строк, которые инициализируются при их объявлении. Однако, как видно из предыдущего раздела, процедурные операции со строками вызывают трудности при работе со строками фиксированной длины, поскольку строки фиксированной длины представляют собой массивы символов. В следующем примере показано, насколько громоздкой может быть инициализация строк фиксированной длины, если она не выполняется в объявлении:

show_char_array.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2

3procedure Show_Char_Array is

4   S : String (1 .. 15);

5   --  Strings are arrays of Character

6begin

7   S := "Hello          ";

8   --  Alternatively:

9   --

10   --  #1:

11   --      S (1 .. 5)      := "Hello";

12   --      S (6 .. S'Last) := (others => ' ');

13   --

14   --  #2:

15   --      S := ('H', 'e', 'l', 'l', 'o',

16   --            others => ' ');

17

18   Put_Line ("String: " & S);

19   Put_Line ("String Length: "

20             & Integer'Image (S'Length));

21end Show_Char_Array;

Runtime output

String: Hello

String Length:  15

В этом случае мы не можем просто написать S := "Hello", потому что результирующий массив символов для константы Hello имеет длину, отличную от длины строки S .Следовательно, нам необходимо включить конечные пробелы, чтобы соответствовать длине S. Как показано в примере, мы могли бы использовать точный диапазон для инициализации (S (1 .. 5)) или использовать явный массив отдельных символов.

Когда строки инициализируются или обрабатываются во время выполнения, обычно лучше использовать ограниченные или неограниченные строки. Важной особенностью этих типов является то, что они не являются массивами, поэтому описанные выше трудности не применяются. Начнем с ограниченных строк.

Ограниченные строки

Ограниченные строки определены в пакете Ada.Strings.Bounded.Generic_Bounded_Length. Поскольку это общий пакет, вам необходимо создать его экземпляр и установить максимальную длину ограниченной строки. Затем вы можете объявить ограниченные строки типа Bounded_String.

Строки как ограниченной, так и фиксированной длины имеют максимальную длину, которую они могут вместить. Однако ограниченные строки не являются массивами, поэтому их инициализация во время выполнения намного проще. Например:

show_bounded_string.adb

1with Ada.Strings;         use Ada.Strings;

2with Ada.Strings.Bounded;

3with Ada.Text_IO;         use Ada.Text_IO;

4

5procedure Show_Bounded_String is

6   package B_Str is new

7     Ada.Strings.Bounded.Generic_Bounded_Length (Max => 15);

8   use B_Str;

9

10   S1, S2 : Bounded_String;

11

12   procedure Display_String_Info (S : Bounded_String) is

13   begin

14      Put_Line ("String: " & To_String (S));

15      Put_Line ("String Length: "

16                & Integer'Image (Length (S)));

17      --  String:

18      --          S'Length => ok

19      --  Bounded_String:

20      --          S'Length => compilation error:

21      --                      bounded strings are

22      --                      not arrays!

23

24      Put_Line ("Max.   Length: "

25                & Integer'Image (Max_Length));

26   end Display_String_Info;

27begin

28   S1 := To_Bounded_String ("Hello");

29   Display_String_Info (S1);

30

31   S2 := To_Bounded_String ("Hello World");

32   Display_String_Info (S2);

33

34   S1 := To_Bounded_String

35     ("Something longer to say here...",

36      Right);

37   Display_String_Info (S1);

38end Show_Bounded_String;

Runtime output

String: Hello

String Length:  5

Max.   Length:  15

String: Hello World

String Length:  11

Max.   Length:  15

String: Something longe

String Length:  15

Max.   Length:  15

Используя ограниченные строки, мы можем легко назначить S1 и S2 несколько раз во время выполнения. Мы используем функции To_Bounded_String и To_String для преобразования в соответствующем направлении между строками фиксированной длины и ограниченными строками. Вызов To_Bounded_String возбуждает исключение, если длина входной строки больше максимальной длинны ограниченной строки. Чтобы этого избежать, мы можем использовать параметр усечения (Right в нашем примере).

Ограниченные строки не являются массивами, поэтому нельзя использовать атрибут 'Length, как это было для строк фиксированной длины. Вместо этого вызывается функция Length, которая возвращает длину ограниченной строки. Константа Max_Length представляет максимальную длину ограниченной строки, заданную при настройке экземпляра пакета.

После инициализации ограниченной строки мы можем с ней работать. Например, мы можем добавить строку в ограниченную строку с помощью Append или выполнить конкатенацию ограниченных строк с помощью оператора &. Вот так:

show_bounded_string_op.adb

1with Ada.Strings;         use Ada.Strings;

2with Ada.Strings.Bounded;

3with Ada.Text_IO;         use Ada.Text_IO;

4

5procedure Show_Bounded_String_Op is

6   package B_Str is new

7     Ada.Strings.Bounded.Generic_Bounded_Length (Max => 30);

8   use B_Str;

9

10   S1, S2 : Bounded_String;

11begin

12   S1 := To_Bounded_String ("Hello");

13   --  Alternatively:

14   --

15   --  A := Null_Bounded_String & "Hello";

16

17   Append (S1, " World");

18   --  Alternatively: Append (A, " World", Right);

19

20   Put_Line ("String: " & To_String (S1));

21

22   S2 := To_Bounded_String ("Hello!");

23   S1 := S1 & " " & S2;

24   Put_Line ("String: " & To_String (S1));

25end Show_Bounded_String_Op;

Runtime output

String: Hello World

String: Hello World Hello!

Мы можем инициализировать ограниченную строку пустой строкой, используя константу Null_Bounded_String. Кроме того, можно использовать процедуру Append и указать режим усечения, как в случае с функцией To_Bounded_String.

Неограниченные строки

Неограниченные строки определяются в пакете Ada.Strings.Unbounded. Это не настраиваемый пакет, поэтому нам не нужно создавать его экземпляр перед использованием Unbounded_String типа. Как можно вспомнить из предыдущего раздела, для ограниченных строк требуется настройка пакета.

Неограниченные строки похожи на ограниченные строки. Главное отличие состоит в том, что они могут содержать строки любого размера и подстраиваться в соответствии с входной строкой: если мы назначим, например, 10-символьную строку неограниченной строке, а позже назначим 50-символьную строку, внутренние операции в контейнере обеспечат выделение памяти для хранения новой строки. В большинстве случаев разработчикам не нужно беспокоиться об этих операциях. Кроме того, усечение не требуется.

Инициализация неограниченных строк очень похожа на ограниченные строки. Рассмотрим пример:

show_unbounded_string.adb

1with Ada.Strings;           use Ada.Strings;

2with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

3with Ada.Text_IO;           use Ada.Text_IO;

4

5procedure Show_Unbounded_String is

6   S1, S2 : Unbounded_String;

7

8   procedure Display_String_Info (S : Unbounded_String) is

9   begin

10      Put_Line ("String: " & To_String (S));

11      Put_Line ("String Length: "

12                & Integer'Image (Length (S)));

13   end Display_String_Info;

14begin

15   S1 := To_Unbounded_String ("Hello");

16   --  Alternatively:

17   --

18   --  A := Null_Unbounded_String & "Hello";

19

20   Display_String_Info (S1);

21

22   S2 := To_Unbounded_String ("Hello World");

23   Display_String_Info (S2);

24

25   S1 := To_Unbounded_String ("Something longer to say here...");

26   Display_String_Info (S1);

27end Show_Unbounded_String;

Runtime output

String: Hello

String Length:  5

String: Hello World

String Length:  11

String: Something longer to say here...

String Length:  31

Как и ограниченные строки, мы можем назначать S1 и S2 несколько раз во время выполнения и использовать функции To_Unbounded_String и To_String для преобразования строк фиксированной длины в неограниченные строками и обратно. В этом случае усечение не нужно.

Как и для ограниченных строк, можно использовать процедуру Append и оператор & для неограниченных строк. Например:

show_unbounded_string_op.adb

1with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

2with Ada.Text_IO;           use Ada.Text_IO;

3

4procedure Show_Unbounded_String_Op is

5   S1, S2 : Unbounded_String := Null_Unbounded_String;

6begin

7   S1 := S1 & "Hello";

8   S2 := S2 & "Hello!";

9

10   Append (S1, " World");

11   Put_Line ("String: " & To_String (S1));

12

13   S1 := S1 & " " & S2;

14   Put_Line ("String: " & To_String (S1));

15end Show_Unbounded_String_Op;

Runtime output

String: Hello World

String: Hello World Hello!

Footnotes

Стандартная библиотека: Файлы и потоки

Ада предлагает различные средства для ввода/вывода файлов (I/O):

- Текстовый ввод-вывод в текстовом формате, включая отображение информации на консоли.

- Последовательный ввод-вывод в двоичном формате последовательным образом для конкретного типа данных.

- Прямой ввод-вывод в двоичном формате для конкретного типа данных, но также поддерживающий доступ к любой позиции файла.

- Потоковый ввод-вывод информации для нескольких типов данных, включая объекты неограниченных типов, с использованием файлов в двоичном формате.

В этой таблице представлено краткое описание функций, которые мы только что видели:

Опция ввода- вывода файлов

Формат

Произвольный доступ

Типы данных

Text I/O

текст

строковый тип

Sequential I/O

двоичный

одиночный тип

Direct I/O

двоичный

да

одиночный тип

Stream I/O

двоичный

да

несколько типов

В следующих разделах мы подробно обсудим эти средства ввода-вывода.

Текстовый ввод-вывод

В большинстве примеров этого курса мы использовали процедуру Put_Line для отображения информации на консоли. Однако эта процедура также принимает параметр File_Type. Например, вы можете выбрать между стандартным выводом (Standard_Output) и выводом стандартной ошибкой (Standard_Error), явно задав этот параметр:

show_std_text_out.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Std_Text_Out is

4begin

5   Put_Line (Standard_Output, "Hello World #1");

6   Put_Line (Standard_Error,  "Hello World #2");

7end Show_Std_Text_Out;

Runtime output

Hello World #1

Hello World #2

Вы также можете использовать этот параметр для записи информации в любой текстовый файл. Чтобы создать новый файл для записи, используйте процедуру Create для инициализации объекта File_Type, который впоследствии можно передать в Put_Line (вместо, например, Standard_Output). После того, как вы закончите запись информации, вы можете закрыть файл, вызвав процедуру Close.

Вы используете аналогичный метод для чтения информации из текстового файла. Однако при открытии файла вы должны указать, что это входной файл (In_File), а не выходной файл. Кроме того, вместо вызова процедуры Put_Line вы вызываете функцию Get_Line для чтения информации из файла.

Давайте посмотрим на пример, который записывает информацию в новый текстовый файл, а затем считывает ее обратно из того же файла:

show_simple_text_file_io.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Simple_Text_File_IO is

4   F         : File_Type;

5   File_Name : constant String := "simple.txt";

6begin

7   Create (F, Out_File, File_Name);

8   Put_Line (F, "Hello World #1");

9   Put_Line (F, "Hello World #2");

10   Put_Line (F, "Hello World #3");

11   Close (F);

12

13   Open (F, In_File, File_Name);

14   while not End_Of_File (F) loop

15      Put_Line (Get_Line (F));

16   end loop;

17   Close (F);

18end Show_Simple_Text_File_IO;

Runtime output

Hello World #1

Hello World #2

Hello World #3

В дополнение к процедурам Create и Close стандартная библиотека также включает процедуру Reset, которая, как следует из названия, сбрасывает (стирает) всю информацию из файла. Например:

show_text_file_reset.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Text_File_Reset is

4   F         : File_Type;

5   File_Name : constant String := "simple.txt";

6begin

7   Create (F, Out_File, File_Name);

8   Put_Line (F, "Hello World #1");

9   Reset (F);

10   Put_Line (F, "Hello World #2");

11   Close (F);

12

13   Open (F, In_File, File_Name);

14   while not End_Of_File (F) loop

15      Put_Line (Get_Line (F));

16   end loop;

17   Close (F);

18end Show_Text_File_Reset;

Runtime output

Hello World #2

Запустив эту программу, мы замечаем, что, хотя мы записали первую строку ("Hello World #1") в файл, она была удалена вызовом процедуры сброса Reset.

В дополнение к открытию файла для чтения или записи, вы также можете открыть существующий файл для добавления в конец. Сделайте это, вызвав процедуру Open с параметром Append_File.

При вызове процедуры открытия Open возбуждает исключение, если указанный файл не найден. Поэтому вы должны обрабатывать исключения в этом контексте. В следующем примере удаляется файл, а затем предпринимается попытка открыть тот же файл для чтения:

show_text_file_input_except.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Show_Text_File_Input_Except is

4   F         : File_Type;

5   File_Name : constant String := "simple.txt";

6begin

7   --  Open output file and delete it

8   Create (F, Out_File, File_Name);

9   Delete (F);

10

11   --  Try to open deleted file

12   Open (F, In_File, File_Name);

13   Close (F);

14exception

15   when Name_Error =>

16      Put_Line ("File does not exist");

17   when others =>

18      Put_Line ("Error while processing input file");

19end Show_Text_File_Input_Except;

Runtime output

File does not exist

В этом примере файл создается вызовом Create, а затем удаляется вызовом Delete. После вызова функции Delete мы больше не можем использовать объект File_Type. После удаления файла мы пытаемся открыть несуществующий файл, что возбуждает исключение Name_Error.

Последовательный ввод-вывод

В предыдущем разделе представлена подробная информация о вводе/выводе текстовых файлов. Здесь мы обсудим выполнение операций ввода-вывода для файловов двоичного формата. Первый пакет, который мы рассмотрим - это Ada.Sequential_IO. Поскольку этот пакет является настраиваемым, необходимо его настроить на тип данных ввод/вывлд которого мы будем производить. После этого можно использовать те же процедуры, что и в предыдущем разделе: Create, Open, Close, Reset и Delete. Однако вместо вызова процедур Get_Line и Put_Line следует вызвать процедуры Read и Write.

В следующем примере создается настройка пакета Ada.Sequential_IO для типов с плавающей запятой:

show_seq_float_io.adb

1with Ada.Text_IO;

2with Ada.Sequential_IO;

3

4procedure Show_Seq_Float_IO is

5   package Float_IO is

6     new Ada.Sequential_IO (Float);

7   use Float_IO;

8

9   F         : Float_IO.File_Type;

10   File_Name : constant String := "float_file.bin";

11begin

12   Create (F, Out_File, File_Name);

13   Write (F,  1.5);

14   Write (F,  2.4);

15   Write (F,  6.7);

16   Close (F);

17

18   declare

19      Value : Float;

20   begin

21      Open (F, In_File, File_Name);

22      while not End_Of_File (F) loop

23         Read (F, Value);

24         Ada.Text_IO.Put_Line (Float'Image (Value));

25      end loop;

26      Close (F);

27   end;

28end Show_Seq_Float_IO;

Runtime output

1.50000E+00

2.40000E+00

6.70000E+00

Мы используем один и тот же подход для чтения и записи сложной структурной информации. В следующем примере используется тип запись, включающая логическое значение типа Boolean и значение с плавающей запятой типа Float:

show_seq_rec_io.adb

1with Ada.Text_IO;

2with Ada.Sequential_IO;

3

4procedure Show_Seq_Rec_IO is

5   type Num_Info is record

6      Valid : Boolean := False;

7      Value : Float;

8   end record;

9

10   procedure Put_Line (N : Num_Info) is

11   begin

12      if N.Valid then

13         Ada.Text_IO.Put_Line ("(ok,     "

14                               & Float'Image (N.Value) & ")");

15      else

16         Ada.Text_IO.Put_Line ("(not ok,  -----------)");

17      end if;

18   end Put_Line;

19

20   package Num_Info_IO is new Ada.Sequential_IO (Num_Info);

21   use Num_Info_IO;

22

23   F         : Num_Info_IO.File_Type;

24   File_Name : constant String := "float_file.bin";

25begin

26   Create (F, Out_File, File_Name);

27   Write (F,  (True,  1.5));

28   Write (F,  (False, 2.4));

29   Write (F,  (True,  6.7));

30   Close (F);

31

32   declare

33      Value : Num_Info;

34   begin

35      Open (F, In_File, File_Name);

36      while not End_Of_File (F) loop

37         Read (F, Value);

38         Put_Line (Value);

39      end loop;

40      Close (F);

41   end;

42end Show_Seq_Rec_IO;

Runtime output

(ok,      1.50000E+00)

(not ok,  -----------)

(ok,      6.70000E+00)

Как показывает пример, мы можем использовать тот же подход, который мы использовали для типов с плавающей запятой, для выполнения файлового ввода-вывода для этой записи. После того, как мы создадим экземпляр пакета Ada.Sequential_IO для типа записи, операции ввода-вывода файлов будут выполняться таким же образом.

Прямой ввод-вывод

Прямой ввод-вывод доступен в пакете Ada.Direct_IO. Этот механизм похож на только что представленный последовательный ввод-вывод, но позволяет нам получить доступ к любой позиции в файле. Создание пакета и большинство операций очень похожи на последовательный ввод-вывод. Чтобы переписать приложение Show_Seq_Float_IO из предыдущего раздела для использования пакета Ada.Direct_IO, нам просто нужно заменить Ada.Sequential_IO на Ada.Direct_IO в настройке пакета. Это новый исходный код:

show_dir_float_io.adb

1with Ada.Text_IO;

2with Ada.Direct_IO;

3

4procedure Show_Dir_Float_IO is

5   package Float_IO is new Ada.Direct_IO (Float);

6   use Float_IO;

7

8   F         : Float_IO.File_Type;

9   File_Name : constant String := "float_file.bin";

10begin

11   Create (F, Out_File, File_Name);

12   Write (F,  1.5);

13   Write (F,  2.4);

14   Write (F,  6.7);

15   Close (F);

16

17   declare

18      Value : Float;

19   begin

20      Open (F, In_File, File_Name);

21      while not End_Of_File (F) loop

22         Read (F, Value);

23         Ada.Text_IO.Put_Line (Float'Image (Value));

24      end loop;

25      Close (F);

26   end;

27end Show_Dir_Float_IO;

Runtime output

1.50000E+00

2.40000E+00

6.70000E+00

В отличие от последовательного ввода-вывода, прямой ввод-вывод позволяет получить доступ к любой позиции в файле. Однако он не предлагает возможность добавлять информацию в конец файла. Вместо этого он предоставляет режим Inout_File, позволяющий читать и записывать в файл через один и тот же объект File_Type.

Чтобы получить доступ к нужной позиции в файле, вызовите процедуру Set_Index и она установит новую позицию / индекс. Вы можете использовать функцию Index чтобы узать текущий индекс. Посмотрим на пример:

show_dir_float_in_out_file.adb

1with Ada.Text_IO;

2with Ada.Direct_IO;

3

4procedure Show_Dir_Float_In_Out_File is

5   package Float_IO is new Ada.Direct_IO (Float);

6   use Float_IO;

7

8   F         : Float_IO.File_Type;

9   File_Name : constant String := "float_file.bin";

10begin

11   --  Open file for input / output

12   Create (F, Inout_File, File_Name);

13   Write (F,  1.5);

14   Write (F,  2.4);

15   Write (F,  6.7);

16

17   --  Set index to previous position and overwrite value

18   Set_Index (F, Index (F) - 1);

19   Write (F,  7.7);

20

21   declare

22      Value : Float;

23   begin

24      --  Set index to start of file

25      Set_Index (F, 1);

26

27      while not End_Of_File (F) loop

28         Read (F, Value);

29         Ada.Text_IO.Put_Line (Float'Image (Value));

30      end loop;

31      Close (F);

32   end;

33end Show_Dir_Float_In_Out_File;

Runtime output

1.50000E+00

2.40000E+00

7.70000E+00

Запустив этот пример, мы видим, что файл содержит значение 7.7 и не содержит значения 6.7, которое мы записали сначала. Мы перезаписали значение, установив индекс на предыдущую позицию перед выполнением следующей операции записи.

В этом примере мы использовали режим Inout_File. Используя этот режим, мы просто вернули индекс в начальное положение перед чтением из файла (Set_Index (F, 1)) вместо того, чтобы закрывать файл и повторно открывать его для чтения.

Потоковый ввод-вывод

Все предыдущие подходы к файловому вводу-выводу в двоичном формате (последовательный и прямой ввод-вывод) работают с одним типом данных (тем, на который мы их настраиваем). Вы можете использовать эти подходы для записи объектов одного типа данных, хотя это может быть массивы или записи (потенциально со многими полями), но если вам нужно создать или обработать файлы, которые включают разные типы данных, либо объекты неограниченного типа, этих средств недостаточно. Вместо этого вы должны использовать потоковый ввод-вывод.

Потоковый ввод-вывод имеет некоторые общие черты с предыдущими подходами. Мы по-прежнему используем процедуры Create, Open и Close. Однако вместо прямого доступа к файлу через объект File_Type вы используете тип Stream_Access. Для чтения и записи информации вы используете атрибуты 'Read или 'Write тех типов данных, которые вы читаете или пишете.

Давайте посмотрим на версию процедуры Show_Dir_Float_IO из предыдущего раздела. Процедура использует потоковый ввод-вывод вместо прямого ввода-вывода:

show_float_stream.adb

1with Ada.Text_IO;

2with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;

3

4procedure Show_Float_Stream is

5   F         : File_Type;

6   S         : Stream_Access;

7   File_Name : constant String := "float_file.bin";

8begin

9   Create (F, Out_File, File_Name);

10   S := Stream (F);

11

12   Float'Write (S, 1.5);

13   Float'Write (S, 2.4);

14   Float'Write (S, 6.7);

15

16   Close (F);

17

18   declare

19      Value : Float;

20   begin

21      Open (F, In_File, File_Name);

22      S := Stream (F);

23

24      while not End_Of_File (F) loop

25         Float'Read (S, Value);

26         Ada.Text_IO.Put_Line (Float'Image (Value));

27      end loop;

28      Close (F);

29   end;

30end Show_Float_Stream;

Runtime output

1.50000E+00

2.40000E+00

6.70000E+00

После вызова Create мы получаем соответствующее значение Stream_Access, вызывая функцию Stream (поток). Затем мы используем этот поток для записи информации в файл используя атрибут 'Write типа Float. После закрытия файла и повторного открытия его для чтения мы снова получаем значение Stream_Access и используем его для чтения информации из файла с помощью атрибута 'Read типа Float.

Вы можете использовать потоки для создания и обработки файлов, содержащих разные типы данных в одном файле. Вы также можете читать и записывать неограниченные типы данных, такие как строки. Однако при использовании неограниченных типов данных вы должны вызывать атрибуты 'Input и 'Output неограниченного типа данных: эти атрибуты записывают информацию о границах или дискриминантах в дополнение к фактическим данным объекта.

В следующем примере показан файловый ввод-вывод, который смешивает как строки разной длины, так и значения с плавающей запятой:

show_string_stream.adb

1with Ada.Text_IO;

2with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;

3

4procedure Show_String_Stream is

5   F         : File_Type;

6   S         : Stream_Access;

7   File_Name : constant String := "float_file.bin";

8

9   procedure Output (S  : Stream_Access;

10                     FV : Float;

11                     SV : String) is

12   begin

13      String'Output (S, SV);

14      Float'Output (S,  FV);

15   end Output;

16

17   procedure Input_Display (S : Stream_Access) is

18      SV : String := String'Input (S);

19      FV : Float  := Float'Input (S);

20   begin

21      Ada.Text_IO.Put_Line (Float'Image (FV)

22                            & " --- " & SV);

23   end Input_Display;

24

25begin

26   Create (F, Out_File, File_Name);

27   S := Stream (F);

28

29   Output (S, 1.5, "Hi!!");

30   Output (S, 2.4, "Hello world!");

31   Output (S, 6.7, "Something longer here...");

32

33   Close (F);

34

35   Open (F, In_File, File_Name);

36   S := Stream (F);

37

38   while not End_Of_File (F) loop

39      Input_Display (S);

40   end loop;

41   Close (F);

42

43end Show_String_Stream;

Build output

show_string_stream.adb:18:07: warning: "SV" is not modified, could be declared constant [-gnatwk]

show_string_stream.adb:19:07: warning: "FV" is not modified, could be declared constant [-gnatwk]

Runtime output

1.50000E+00 --- Hi!!

2.40000E+00 --- Hello world!

6.70000E+00 --- Something longer here...

Когда вы используете потоковый ввод-вывод, в файл не записывается никакая информация, указывающая тип данных, которые вы записали. Если файл содержит данные разных типов, при чтении файла вы должны ссылаться на типы в том же порядке, что и при его написании. В противном случае полученная информация будет повреждена. К сожалению, строгая типизация данных в этом случае вам не поможет. Написание простых процедур для файлового ввода-вывода (как в приведенном выше примере) может помочь обеспечить согласованность формата файла.

Как и прямой ввод-вывод, поддержка потокового ввода-вывода также позволяет получить доступ к любому месту в файле. Однако при этом нужно быть предельно осторожным, чтобы положение нового индекса соответствовало ожидаемым типам данных.

Footnotes

Стандартная библиотека: Numerics

Стандартная библиотека обеспечивает поддержку широко распространенных математических операций для типов с плавающей запятой, комплексных чисел и матриц. В нижеследующих разделах приводится краткое введение в эти математические операции.

Элементарные функции

Пакет Ada.Numerics.Elementary_Functions обеспечивает общепринятые операции для типов с плавающей точкой, такие как квадратный корень, логарифм и тригонометрические функции (типа sin, cos). Например:

show_elem_math.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Ada.Numerics; use Ada.Numerics;

3

4with Ada.Numerics.Elementary_Functions;

5use  Ada.Numerics.Elementary_Functions;

6

7procedure Show_Elem_Math is

8   X : Float;

9begin

10   X := 2.0;

11   Put_Line ("Square root of "

12             & Float'Image (X)

13             & " is "

14             & Float'Image (Sqrt (X)));

15

16   X := e;

17   Put_Line ("Natural log of "

18             & Float'Image (X)

19             & " is "

20             & Float'Image (Log (X)));

21

22   X := 10.0 ** 6.0;

23   Put_Line ("Log_10      of "

24             & Float'Image (X)

25             & " is "

26             & Float'Image (Log (X, 10.0)));

27

28   X := 2.0 ** 8.0;

29   Put_Line ("Log_2       of "

30             & Float'Image (X)

31             & " is "

32             & Float'Image (Log (X, 2.0)));

33

34   X := Pi;

35   Put_Line ("Cos         of "

36             & Float'Image (X)

37             & " is "

38             & Float'Image (Cos (X)));

39

40   X := -1.0;

41   Put_Line ("Arccos      of "

42             & Float'Image (X)

43             & " is "

44             & Float'Image (Arccos (X)));

45end Show_Elem_Math;

Runtime output

Square root of  2.00000E+00 is  1.41421E+00

Natural log of  2.71828E+00 is  1.00000E+00

Log_10      of  1.00000E+06 is  6.00000E+00

Log_2       of  2.56000E+02 is  8.00000E+00

Cos         of  3.14159E+00 is -1.00000E+00

Arccos      of -1.00000E+00 is  3.14159E+00

Здесь мы используем стандартные константы e и Pi из пакета Ada.Numerics.

Пакет Ada.Numerics.Elementary_Functions предоставляет операции для типа Float. Аналогичные пакеты есть для типов Long_Float и Long_Long_Float. Например, пакет Ada.Numerics.Long_Elementary_Functions предлагает тот же набор операций для типа Long_Float. Кроме того, пакет Ada.Numerics.Generic_Elementary_Functions - это настраиваемая версия пакета, которую можно использовать для пользовательских типов с плавающей запятой. Фактически, пакет Elementary_Functions можно определить следующим образом:

package Elementary_Functions is new

Ada.Numerics.Generic_Elementary_Functions (Float);

Генерация случайных чисел

Пакет Ada.Numerics.Float_Random предоставляет простой генератор случайных чисел с диапазоном от 0,0 до 1,0. Чтобы использовать его, объявите генератор G, который вы затем передадите в Random. Например:

show_float_random_num.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random;

3

4procedure Show_Float_Random_Num is

5   G : Generator;

6   X : Uniformly_Distributed;

7begin

8   Reset (G);

9

10   Put_Line ("Some random numbers between "

11             & Float'Image (Uniformly_Distributed'First)

12             & " and "

13             & Float'Image (Uniformly_Distributed'Last)

14             & ":");

15   for I in 1 .. 15 loop

16      X := Random (G);

17      Put_Line (Float'Image (X));

18   end loop;

19end Show_Float_Random_Num;

Runtime output

Some random numbers between  0.00000E+00 and  1.00000E+00:

9.29413E-01

6.83346E-01

2.30866E-01

9.41220E-01

7.81104E-01

5.04554E-01

2.73398E-01

9.05950E-01

6.31678E-01

7.84824E-01

4.11724E-01

9.77724E-01

5.53477E-01

8.14905E-01

2.13336E-01

Стандартная библиотека также включает генератор случайных чисел для дискретных чисел, который является частью пакета Ada.Numerics.Discrete_Random. Поскольку это настраиваемый пакет, необходимо создать его экземпляр для требуемого дискретного типа. Это позволяет вам задать диапазон генератора. В следующем примере создается приложение, отображающее случайные целые числа от 1 до 10:

show_discrete_random_num.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Ada.Numerics.Discrete_Random;

3

4procedure Show_Discrete_Random_Num is

5

6   subtype Random_Range is Integer range 1 .. 10;

7

8   package R is new

9     Ada.Numerics.Discrete_Random (Random_Range);

10   use R;

11

12   G : Generator;

13   X : Random_Range;

14begin

15   Reset (G);

16

17   Put_Line ("Some random numbers between "

18             & Integer'Image (Random_Range'First)

19             & " and "

20             & Integer'Image (Random_Range'Last)

21             & ":");

22

23   for I in 1 .. 15 loop

24      X := Random (G);

25      Put_Line (Integer'Image (X));

26   end loop;

27end Show_Discrete_Random_Num;

Runtime output

Some random numbers between  1 and  10:

1

1

9

4

3

9

4

4

6

6

8

1

2

2

7

Здесь пакет R создается с типом Random_Range с ограничением диапазона от 1 до 10. Это позволяет нам контролировать диапазон получаемых случайных чисел. Мы могли бы легко изменить приложение для получения случайных целых чисел от 0 до 20, изменив спецификацию подтипа Random_Range. Аналогично мы можем использовать типы с плавающей запятой и с фиксированной запятой.

Комплексные числа

Пакет Ada.Numerics.Complex_Types обеспечивает поддержку комплексных чисел, а пакет Ada.Numerics.Complex_Elementary_Functions обеспечивает поддержку общепринятые операций с типами комплексных чисел, аналогично пакету Ada.Numerics.Elementary_Functions. Наконец, вы можете использовать пакет Ada.Text_IO.Complex_IO для выполнения операций ввода-вывода над комплексными числами. В следующем примере мы объявляем переменные типа Complex и инициализируем их с помощью агрегата:

show_elem_math.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2with Ada.Numerics; use Ada.Numerics;

3

4with Ada.Numerics.Complex_Types;

5use  Ada.Numerics.Complex_Types;

6

7with Ada.Numerics.Complex_Elementary_Functions;

8use  Ada.Numerics.Complex_Elementary_Functions;

9

10with Ada.Text_IO.Complex_IO;

11

12procedure Show_Elem_Math is

13

14   package C_IO is new

15     Ada.Text_IO.Complex_IO (Complex_Types);

16   use C_IO;

17

18   X, Y  : Complex;

19   R, Th : Float;

20begin

21   X := (2.0, -1.0);

22   Y := (3.0,  4.0);

23

24   Put (X);

25   Put (" * ");

26   Put (Y);

27   Put (" is ");

28   Put (X * Y);

29   New_Line;

30   New_Line;

31

32   R  := 3.0;

33   Th := Pi / 2.0;

34   X  := Compose_From_Polar (R, Th);

35   --  Alternatively:

36   --  X := R * Exp ((0.0, Th));

37   --  X := R * e ** Complex'(0.0, Th);

38

39   Put ("Polar form:    "

40        & Float'Image (R)  & " * e**(i * "

41        & Float'Image (Th) & ")");

42   New_Line;

43

44   Put ("Modulus     of ");

45   Put (X);

46   Put (" is ");

47   Put (Float'Image (abs (X)));

48   New_Line;

49

50   Put ("Argument    of ");

51   Put (X);

52   Put (" is ");

53   Put (Float'Image (Argument (X)));

54   New_Line;

55   New_Line;

56

57   Put ("Sqrt        of ");

58   Put (X);

59   Put (" is ");

60   Put (Sqrt (X));

61   New_Line;

62end Show_Elem_Math;

Runtime output

( 2.00000E+00,-1.00000E+00) * ( 3.00000E+00, 4.00000E+00) is ( 1.00000E+01, 5.00000E+00)

Polar form:     3.00000E+00 * e**(i *  1.57080E+00)

Modulus     of (-1.31134E-07, 3.00000E+00) is  3.00000E+00

Argument    of (-1.31134E-07, 3.00000E+00) is  1.57080E+00

Sqrt        of (-1.31134E-07, 3.00000E+00) is ( 1.22474E+00, 1.22474E+00)

Как видно из этого примера, все общепринятые операции, такие, как * и +, доступны для комплексных типов. У вас также есть типичные операции комплексных чисел, такие как Argument и Exp. Помимо инициализации комплексных чисел в декартовой форме с использованием агрегатов, вы можете получать их из полярной формы, вызвав функцию Compose_From_Polar.

Пакеты Ada.Numerics.Complex_Types и Ada.Numerics.Complex_Elementary_Functions предоставляют операции для типа Float. Подобные пакеты доступны для типов Long_Float и Long_Long_Float. Кроме того, с помощью настраиваемых пакетов Ada.Numerics.Generic_Complex_Types и Ada.Numerics.Generic_Complex_Elementary_Functions можно создавать комплексные типы и их функции из пользовательских или предопределенных типов с плавающей запятой. Например:

with Ada.Numerics.Generic_Complex_Types;

with Ada.Numerics.Generic_Complex_Elementary_Functions;

with Ada.Text_IO.Complex_IO;

procedure Show_Elem_Math is

package Complex_Types is new

Ada.Numerics.Generic_Complex_Types (Float);

use Complex_Types;

package Elementary_Functions is new

Ada.Numerics.Generic_Complex_Elementary_Functions

(Complex_Types);

use Elementary_Functions;

package C_IO is new Ada.Text_IO.Complex_IO

(Complex_Types);

use C_IO;

X, Y  : Complex;

R, Th : Float;

Работа с векторами и матрицами

Пакет Ada.Numerics.Real_Arrays обеспечивает поддержку векторов и матриц. Он включает в себя типичные операции с матрицами, такие как обращение, нахождение определителя и собственного значения, а также более простые операции, такие как сложение и умножение матриц. Вы можете объявлять векторы и матрицы, используя типы Real_Vector и Real_Matrix соответственно.

В следующем примере используются некоторые операции из пакета Ada.Numerics.Real_Arrays:

show_matrix.adb

1with Ada.Text_IO;  use Ada.Text_IO;

2

3with Ada.Numerics.Real_Arrays;

4use  Ada.Numerics.Real_Arrays;

5

6procedure Show_Matrix is

7

8   procedure Put_Vector (V : Real_Vector) is

9   begin

10      Put ("    (");

11      for I in V'Range loop

12         Put (Float'Image (V (I)) & " ");

13      end loop;

14      Put_Line (")");

15   end Put_Vector;

16

17   procedure Put_Matrix (M : Real_Matrix) is

18   begin

19      for I in M'Range (1) loop

20         Put ("    (");

21         for J in M'Range (2) loop

22            Put (Float'Image (M (I, J)) & " ");

23         end loop;

24         Put_Line (")");

25      end loop;

26   end Put_Matrix;

27

28   V1       : Real_Vector := (1.0, 3.0);

29   V2       : Real_Vector := (75.0, 11.0);

30

31   M1       : Real_Matrix :=

32                ((1.0, 5.0, 1.0),

33                 (2.0, 2.0, 1.0));

34   M2       : Real_Matrix :=

35                ((31.0, 11.0, 10.0),

36                 (34.0, 16.0, 11.0),

37                 (32.0, 12.0, 10.0),

38                 (31.0, 13.0, 10.0));

39   M3       : Real_Matrix := ((1.0, 2.0),

40                              (2.0, 3.0));

41begin

42   Put_Line ("V1");

43   Put_Vector (V1);

44   Put_Line ("V2");

45   Put_Vector (V2);

46   Put_Line ("V1 * V2 =");

47   Put_Line ("    "

48             & Float'Image (V1 * V2));

49   Put_Line ("V1 * V2 =");

50   Put_Matrix (V1 * V2);

51   New_Line;

52

53   Put_Line ("M1");

54   Put_Matrix (M1);

55   Put_Line ("M2");

56   Put_Matrix (M2);

57   Put_Line ("M2 * Transpose(M1) =");

58   Put_Matrix (M2 * Transpose (M1));

59   New_Line;

60

61   Put_Line ("M3");

62   Put_Matrix (M3);

63   Put_Line ("Inverse (M3) =");

64   Put_Matrix (Inverse (M3));

65   Put_Line ("abs Inverse (M3) =");

66   Put_Matrix (abs Inverse (M3));

67   Put_Line ("Determinant (M3) =");

68   Put_Line ("    "

69             & Float'Image (Determinant (M3)));

70   Put_Line ("Solve (M3, V1) =");

71   Put_Vector (Solve (M3, V1));

72   Put_Line ("Eigenvalues (M3) =");

73   Put_Vector (Eigenvalues (M3));

74   New_Line;

75end Show_Matrix;

Build output

show_matrix.adb:28:04: warning: "V1" is not modified, could be declared constant [-gnatwk]

show_matrix.adb:29:04: warning: "V2" is not modified, could be declared constant [-gnatwk]

show_matrix.adb:31:04: warning: "M1" is not modified, could be declared constant [-gnatwk]

show_matrix.adb:34:04: warning: "M2" is not modified, could be declared constant [-gnatwk]

show_matrix.adb:39:04: warning: "M3" is not modified, could be declared constant [-gnatwk]

Runtime output

V1

( 1.00000E+00  3.00000E+00 )

V2

( 7.50000E+01  1.10000E+01 )

V1 * V2 =

1.08000E+02

V1 * V2 =

( 7.50000E+01  1.10000E+01 )

( 2.25000E+02  3.30000E+01 )

M1

( 1.00000E+00  5.00000E+00  1.00000E+00 )

( 2.00000E+00  2.00000E+00  1.00000E+00 )

M2

( 3.10000E+01  1.10000E+01  1.00000E+01 )

( 3.40000E+01  1.60000E+01  1.10000E+01 )

( 3.20000E+01  1.20000E+01  1.00000E+01 )

( 3.10000E+01  1.30000E+01  1.00000E+01 )

M2 * Transpose(M1) =

( 9.60000E+01  9.40000E+01 )

( 1.25000E+02  1.11000E+02 )

( 1.02000E+02  9.80000E+01 )

( 1.06000E+02  9.80000E+01 )

M3

( 1.00000E+00  2.00000E+00 )

( 2.00000E+00  3.00000E+00 )

Inverse (M3) =

(-3.00000E+00  2.00000E+00 )

( 2.00000E+00 -1.00000E+00 )

abs Inverse (M3) =

( 3.00000E+00  2.00000E+00 )

( 2.00000E+00  1.00000E+00 )

Determinant (M3) =

-1.00000E+00

Solve (M3, V1) =

( 3.00000E+00 -1.00000E+00 )

Eigenvalues (M3) =

( 4.23607E+00 -2.36068E-01 )

Если вы не указываете размеры матрицы, они автоматически определяются на основе агрегата, используемого для инициализации. Хотя вы также можете использовать явные диапазоны. Например:

M1       : Real_Matrix (1 .. 2, 1 .. 3) :=

((1.0, 5.0, 1.0),

(2.0, 2.0, 1.0));

Пакет Ada.Numerics.Real_Arrays предоставляет операции для типа Float. Аналогичные пакеты доступны для типов Long_Float и Long_Long_Float. Кроме того, настраиваемый пакет Ada.Numerics.Generic_Real_Arrays можно использовать для пользовательских типов с плавающей запятой. Например, пакет Real_Arrays может быть определен следующим образом:

package Real_Arrays is new

Ada.Numerics.Generic_Real_Arrays (Float);

Footnotes

Приложения

Приложение A: Формальные типы настройки

Следующие таблицы содержат примеры доступных формальных типов настраиваемых модулей:

Формальный тип

Фактический тип

Неполный тип

Формат: type T;

Любой тип

Дискретный тип

Формат: type T is (<>);

Любой целочисленный тип, модульный тип или перечислимый тип

Тип диапазона

Формат: type T is range <>;

Любой целочисленный тип со знаком

Модульный тип

Формат: type T is mod <>;

Любой модульный тип

Тип с плавающей запятой

Формат: type T is digits <>;

Любой тип с плавающей запятой

Двоичный тип с фиксированной запятой

Формат: type T is delta <>;

Любой двоичный тип с фиксированной запятой

Десятичный тип с фиксированной запятой

Формат: type T is delta <> digits <>;

Любой десятичный тип с фиксированной запятой

Определенный нелимитируемый личный тип

Формат: type T is private;

Любой нелимитируемый, определенный тип

Нелимитируемый личный тип с дискриминантом

Формат: type T (D : DT) is private;

Любой нелимитируемый тип с дискриминантом

Ссылочный тип

Формат: type A is access T;

Любой ссылочный тип для типа T

Определенный производный тип

Формат: type T is new B;

Любой конкретный тип, производный от базового типа B

Лимитируемый частный тип

Формат: type T is limited private;

Любой определенный тип, лимитируемый или нет

Неполное описание тегового типа

Формат: type T is tagged;

Любой конкретный, определенный, теговый тип

Определенный теговый личный тип

Формат: type T is tagged private;

Любой конкретный, определенный, теговый тип

Определенный теговый лимитируемый личный тип

Формат: type T is tagged limited private;

Любой конкретный определенный теговый тип лимитируемый или нет.

Определенный абстрактный теговый личный тип

Формат: type T is abstract tagged private;

Любой нелимитируемый, определенный теговый тип абстрактный или конкретный

Определенный абстрактный теговый лимитируемый личный тип

Формат: type T is abstract tagged limited private;

Любой определенный теговый тип, лимитир-мый или нет, абстрактный или конкретный

Определенный производный теговый тип

Формат: type T is new B with private;

Любой конкретный теговый тип, производный от базового типа B

Определенный абстрактный производный теговый тип

Формат: type T is abstract new B with private;

Любой теговый тип, производный от базового типа B абстрактный или конкретный

Тип массива

Формат: type A is array (R) of T;

Любой тип массива с диапазоном R, содержащий элементы типа T

Интерфейсный тип

Формат: type T is interface;

Любой интерфейсный тип

Лимитируемый интерфейсный тип

Формат: type T is limited interface;

Любой лимитируемый интерфейсный тип

Задачный интерфейсный тип

Формат: type T is task interface;

Любой задачный интерфейсный тип

Синхронизированный интерфейсный тип

Формат: type T is synchronized interface;

Любой синхронизированный интерфейсный тип

Защищенный интерфейсный тип

Формат: type T is protected interface;

Любой защищенный интерфейсный тип

Производный интерфейсный тип

Формат: type T is new B and I with private;

Любой тип, производный от базового типа B и интерфейса I

Производный тип с несколькими интерфейсами

Формат: type T is new B and I1 and I2 with private;

Любой тип, производный от базового типа B и интерфейсов I1 и I2

Абстрактный производный интерфейсный тип

Формат: type T is abstract new B and I with private;

Любой тип, производный от абстрактного базового типа B и интерфейса I

Лимитируемый производный интерфейсный тип

Формат: type T is limited new B and I with private;

Любой тип, производный от лимитируемого базового типа B и лимитируемого интерфейса

Абстрактный лимитируемый производный интерфейсный тип

Формат: type T is abstract limited new B and I with private;

Любой тип, производный от абстрактного лимитиру емого базового типа B и лимитируемого интерфейса

Синхронизированный интерфейсный тип

Формат: type T is synchronized new SI with private;

Любой тип, производный от синхронизированного интерфейсного типы SI

Абстрактный синхронизированный интерфейсный тип

Формат: type T is abstract synchronized new SI with private;

Любой тип, производный от синхронизированного интерфейса SI

Неопределенные версии типов

Многие из приведенных выше примеров могут быть использованы для формальных неопределенных типов:

Формальный тип

Фактический тип

Неопределенный неполный тип

Формат: type T (<>);

Любой тип

Неопределенный нелимитируемый личный тип

Формат: type T (<>) is private;

Любой нелимитируемый тип неопределенный или определенный

Неопределенный лимитируемый личный тип

Формат: type T (<>) is limited private;

Любой тип, лимитируемый или нет, неопределенный или определенный

Неполный неопределенный личный теговый тип

Формат: type T (<>) is tagged;

Любой конкретный теговый тип, неопределенный или определенный

Неопределенный теговый личный тип

Формат: type T (<>) is tagged private;

Любой конкретный, нелимитируемый теговый тип, неопределенный или определенный

Неопределенный теговый лимитируемый личный типми

Формат: type T (<>) is tagged limited private;

Любой конкретный теговый тип, лимитируемый или нет, неопределенный или определенный

Неопределенный абстрактный теговый личный тип

Формат: type T (<>) is abstract tagged private;

Любой нелимитируемый тег овый тип, неопределенный или определенный, абстрактный или конкретный

Неопределенный абстрактный теговый лимитируемый личный тип

Формат: type T (<>) is abstract tagged limited private;

Любой теговый тип, лимитируемый или нет, неопределенный или определенный,абстрактный или конкретный

Неопределенный производный теговый тип

Формат: type T (<>) is new B with private;

Любой теговый тип, производный от базового типа B, неопределенный или определенный

Неопределенный абстрактный производный теговый тип

Формат: type T (<>) is abstract new B with private;

Любой тегоый тип, производный от базового типа B, неопределенный или определенный абстрактный или конкретный

Те же примеры могут также содержать дискриминанты. В этом случае, (<>) заменяется списком дискриминантов, например: (D: DT).

Приложение B: Контейнеры

В следующей таблице показаны все контейнеры, доступные в Аде, включая их версии (стандартный, ограниченный, неограниченный, неопределенный):

Категория

Контейнер

Std

Bounded

Unbounded

Indefinite

Вектор

Vectors

Y

Y

Y

Список

Doubly Linked Lists

Y

Y

Y

Отображение

Hashed Maps

Y

Y

Y

Отображение

Ordered Maps

Y

Y

Y

Множество

Hashed Sets

Y

Y

Y

Множество

Ordered Sets

Y

Y

Y

Дерево

Multiway Trees

Y

Y

Y

Универсальн

Holders

Y

Очередь

Synchronized Queue Interfaces

Y

Очередь

Synchronized Queues

Y

Y

Очередь

Priority Queues

Y

Y

Note

Чтобы получить имя пакета контейнера, замените пробел на _ в его названии. (Например, пакет для Hashed Maps называется Hashed_Maps.)

В следующей таблице представлены префиксы, применяемые к имени контейнера, которые зависят от его версии. Как указано в таблице, стандартная версия не имеет связанного с ней префикса.

Версия

Префикс именования

Std

Ограниченный

Bounded_

Неограниченный

Unbounded_

Неопределенный

Indefinite_

Footnotes

Безопасное и надежное программное обеспечение

Release 2022-08

Aug 22, 2022

Целью данной брошюры является продемонстрировать, как изучение языка Ада в целом и возможностей, введенных в редакциях Ада 2005, Ада 2012, в частности, поможет Вам разрабатывать безопасное и надежное программное обеспечение независимо от выбранного Вами языка реализации.

Contents:

- Вступление

- Предисловие

- Безопасный синтаксис

- Присваивание и проверка на равенство

- Группы инструкций

- Именованное сопоставление

- Целочисленные литералы

- Безопасные типы данных

- Использование индивидуальных типов

- Перечисления и целые

- Ограничения и подтипы

- Предикаты подтипов

- Массивы и ограничения

- Установка начальных значений по умолчанию

- «Вещественные ошибки»

- Безопасные указатели

- Ссылки, указатели и адреса

- Ссылочные типы и строгая типизация

- Ссылочные типы и контроль доступности

- Ссылки на подпрограммы

- Вложенные подпрограммы в качестве параметров

- Безопасная архитектура

- Спецификация и тело пакета

- Приватные типы

- Контрактная модель настраиваемых модулей

- Дочерние модули

- Модульное тестирование

- Взаимозависимые типы

- Контрактное программирование

- Безопасное объектно‐ориентированное программирование

- ООП вместо структурного программирования

- Индикатор overriding

- Запрет диспетчеризации вызова подпрограмм

- Интерфейсы и множественное наследование

- Взаимозаменяемость

- Безопасное создание объектов

- Переменные и константы

- Функция-конструктор

- Лимитируемые типы

- Контролируемые типы

- Безопасное управление памятью

- Переполнение буфера

- Динамическое распределение памяти

- Пулы памяти

- Ограничения

- Безопасный запуск

- Предвыполнение

- Директивы компилятору, связанные с предвыполнением

- Динамическая загрузка

- Безопасная коммуникация

- Представление данных

- Корректность данных

- Взаимодействие с другими языками

- Потоки ввода/вывода

- Фабрики объектов

- Безопасный параллелизм

- Операционные системы и задачи

- Защищенные объекты

- Рандеву

- Ограничения

- Ravenscar

- Безопасное завершение

- Время и планирование

- Сертификация с помощью SPARK

- Контракты

- SPARK — подмножество языка Ада

- Формальные методы анализа

- Гибридная верификация

- Примеры

- Сертификация

- Дальнейший процесс

- Заключение

- Список литературы

Footnotes

Вступление

Целью данной брошюры является продемонстрировать, как изучение языка Ада в целом и возможностей, введенных в редакциях Ада 2005, Ада 2012, в частности, поможет Вам разрабатывать безопасное и надежное программное обеспечение независимо от выбранного языка реализации. В конце концов, успешные реализации такого сорта программного обеспечения пишутся в духе Ады на любом языке! Спасибо Джону, постоянно демонстрирующему это в своих статьях, книгах и данной брошюре.

AdaCore посвящает эту брошюру памяти доктора Jean Ichbiah (1940-2007) — главному архитектору первой редакции языка Ада, заложившему надежный фундамент всех последующих редакций языка.

Франко Гасперони

Главный Исполнительный Директор, AdaCore

Париж, январь 2013

Footnotes

Предисловие

Перед вами новая редакция брошюры «Безопасное и надежное программированное обеспечение». Она включает описание новых возможностей языка для поддержки контрактного программирования. Данные новшества были введены в ревизию языка Ада 2012. Они представляют особый интерес в областях, где существуют повышенные требования к безопасности и надежности программного обеспечения, особенно когда речь заходит о сертификации программ.

Я очень благодарен Бену Брасголу (Ben Brosgol) из AdaCore за помощь в подготовке новой редакции этой брошюры. Бен не только подготовил черновик новых разделов, но также исправил некоторые неясные, вводящие в заблуждения, а то и вовсе некорректные моменты в оригинале. К тому же он подготовил всеобъемлющий индекс, который, я уверен, оценят все читатели.

Джон Барнс.

Кавершам. Англия. Январь 2013

С момента публикации предыдущей редакции этой брошюры в 2013 году произошло важное событие: был выпущен SPARK 2014. SPARK представляет собой подмножество языка Ада, позволяющее применить методы формального анализа свойств программы, например, доказать отсуствие ошибок в коде. При этом остается возможность сочетать формальные методы с традиционными методами тестирования программ. Соответствующая глава «Сертификация с помощью SPARK» была значительно переработана, чтобы отразить изменения, введенные в SPARK 2014. Мы надеемся, что эта обновленная глава воодушевит читателей познакомиться поближе с этим интереснейшим новым языком и соответствующими технологиями.

Footnotes

Безопасный синтаксис

Часто сам синтаксис относят к скучным техническим деталям. Аргументируется это так — важно что именно вы скажете. При этом не так важно как вы это скажете. Это конечно же неверно. Ясность и однозначность очень важны при любом общении в цивилизованном мире.

Проводя аналогию, программа — это средство коммуникации между автором и читателем, будь то компилятор, другой член команды разработчиков, ответственный за контроль качества кода, либо любой другой человек. В самом деле, ведь чтение — это тоже способ общения. Ясный и однозначный синтаксис будет значительным подспорьем в подобном общении и, как мы убедимся далее, позволит избежать многих распространенных ошибок.

Важным свойством хорошо спроектированного синтаксиса является возможность находить ошибки в программе, вызванные типичными опечатками. Это позволит выявить их в момент компиляции вместо того, чтобы получить программу с непреднамеренным смыслом. Хотя тяжело предотвратить такие опечатки, как X вместо Y и + вместо *, многие опечатки, влияющие на структуру программы могут быть предотвращены. Заметим, однако, что полезно избегать коротких идентификаторов как раз по этой причине. К примеру, если финансовая программа оперирует курсом и временем, использовать в ней идентификаторы R и T чревато ошибками, поскольку легко ошибиться при наборе текста, ведь эти буквы находятся рядом на клавиатуре. В случае же использования идентификаторов Rate и Time возможные опечатки Tate, Rime будут легко выявлены компилятором.

Присваивание и проверка на равенство

Очевидно, что присваивание и проверка на равенство это разные действия. Если мы выполняем присваивание, мы изменяем состояние некоторой переменной. В то время как сравнение на равенство просто проверяет некоторое условие. Изменение состояния и проверка условия совершенно различные операции и осознавать это важно.

Во многих языках программирования запись этих операций может ввести в заблуждение.

Так в Fortran-е со дня его появления пишется:

X = X + 1

Но это весьма причудливая запись. В математике X никогда не равен X + 1. Данная инструкция в Fortran-е означает конечно же «заменить текущее значение переменной X старым значением, увеличенным на единицу». Но зачем использовать знак равенства таким способом, если в течении столетий он использовался для обозначения сравнения? (Знак равенства был предложен в 1550 году английским математиком Робертом Рекордом.) Создатели языка Algol 60 обратили внимание на эту проблему и использовали комбинацию двоеточия и знака равенства для записи операции присваивания:

X := X + 1;

Таким образом знак равенства можно использовать в операциях сравнения не теряя однозначности:

if X = 0 then ...

Язык C использует = для операции присваивания и, как следствие, вводит для операции сравнения двойной знак равенства (==). Это может запутать еще больше.

Вот фрагмент программы на C для управления воротами железной дороги:

if (the_signal == clean)

{

open_gates(...);

start_train(...);

}

Та же программа на языке Ада:

if The_Signal = Clean then

Open_Gates(...);

Start_Train(...);

end if;

Посмотрим, что будет, если C-программист допустит опечатку, введя единичный знак равенства вместо двойного:

if (the_signal = clean)

{

open_gates(...);

start_train(...);

}

Компиляция пройдет без ошибок, но вместо проверки the_signal произойдет присваивание значения clean переменной the_signal. Более того, в C нет различия между выражениями (вычисляющими значения) и присваиваниями (изменяющими состояние). Поэтому присваивание работает как выражение, а присвоенное значение затем используется в проверке условия. Если так случится, что clean не равно нулю, то условие будет считаться истинным, ворота откроются, the_signal примет значение clean и поезд уйдет в свой опасный путь. В противном случае, если clean закодирован как ноль, проверка не пройдет, ворота останутся заперты, а поезд — заблокированным. В любом случае все пойдет совсем не так, как нужно.

Ошибки связанные с использованием = для присваивания и == для проверки на равенство, то есть присваивания вместо выражений хорошо знакомы в C-сообществе. Для их выявления появились дополнительные правила оформления кода MISRA C[3] и средства анализа кода, такие как lint. Однако, следовало бы избежать подобных ловушек с самого момента разработки языка, что и было достигнуто в Аде.

Если Ада-программист по ошибке использует присваивание вместо проверки:

if The_Signal := Clean then  --  Ошибка

то программа просто не скомпилируется и все будет хорошо.

Группы инструкций

Часто необходимо сгруппировать последовательность из нескольких инструкций, например после проверки в условном операторе. Есть два типичных пути для этого:

- взять всю группу в скобки (как в C),

- закрыть последовательность чем-то, отвечающим '''if''' (как в Аде).

В C мы получим:

if (the_signal == clean)

{

open_gates(...);

start_train(...);

}

и, допустим, случайно добавим точку с запятой в конец первой строки. Получится следующее:

if (the_signal == clean) ;

{

open_gates(...);

start_train(...);

}

Теперь условие применяется только к пустому оператору, который неявно присутствует между условием и вновь введенным символом точки с запятой. Он практически невидим. И теперь не важно состояние the_signal, ворота все равно откроются и поезд поедет.

Вот для Ады соответствующая ошибка:

if The_Signal = Clean; then

Open_Gates(...);

Start_Train(...);

end if;

Это синтаксически неправильная запись, поэтому компилятор с легкостью ее обнаружит и предотвратит крушение поезда.

Именованное сопоставление

Еще одним свойством Ады синтаксической природы, помогающим избежать разнообразных ошибок, является именованная ассоциация, используемая в различных конструкциях. Хорошим примером может выступать запись даты, потому, что порядок следования ее составляющих различается в разных странах. К примеру 12 января 2008 года в Европе записывают, как 12/01/08, а в США обычно пишут 01/12/08 (не считая последних таможенных деклараций). В тоже время стандарт ISO требует писать вначале год — 08/01/12.

В C структура для хранения даты выглядит так:

struct date {

int day, month, year;

};

что соответствует следующему типу в Аде:

type Date is record

Day, Month, Year : Integer;

end record;

В C мы можем написать:

struct date today = {1, 12, 8};

Но не имея перед глазами описания типа, мы не можем сказать, какая дата имеется в виду: 1 декабря 2008, 12 января 2008 или 8 декабря 2001.

В Аде есть возможность записать так:

Today : Date := (Day => 1, Month => 12, Year => 08);

Здесь используется именное сопоставление. Теперь не будет разночтений, даже, если мы запишем компоненты в другом порядке. (Заметьте, что в Аде допустимы лидирующие нули).

Следующая запись:

Today : Date := (Month => 12, Day => 1, Year => 08);

по-прежнему корректна и демонстрирует преимущество — нам нет нужды помнить порядок следования компонента записи.

Именованное сопоставление используется и в других конструкциях Ады. Подобные ошибки могут появляться при вызове подпрограмм, имеющих несколько параметров одного типа. Допустим, у нас есть функция вычисления индекса ожирения человека. Она имеет два параметра — высота и вес, заданные в фунтах и дюймах (либо в килограммах и метрах, для метрической системы измерений). В C мы имеем:

float index(float height, float weight) {

...

return ...;

}

А в Аде:

function Index (Height, Weight : Float) return Float is

...

return ...;

end;

Вызов функции index в C для автора примет вид:

my_index = index(68.0, 168.0);

Но по ошибке легко перепутать:

my_index = index(168.0, 68.0);

в результате вы становитесь очень тощим, но высоким гигантом! (По забавному совпадению оба числа оканчиваются на 68.0).

Такой нездоровой ситуации можно избежать в Аде, используя именованное сопоставление параметров в вызове:

My_Index := Index (Height => 68.0, Weight => 168.0);

Опять-таки, мы можем перечислять параметры в любом порядке, в каком пожелаем, ничего не случится, если мы забудем, в каком порядке они следуют в определении функции.

Именованное сопоставление очень ценная конструкция языка Ада. Хотя его использование не является обязательным, им стоит пользоваться как можно чаще, т. к. кроме защиты от ошибок, оно значительно улучшает читаемость программы.

Целочисленные литералы

Обычно целочисленные литералы не часто встречаются в программе, за исключением может быть 0 и 1. Целочисленные литералы должны в основном использоваться для инициализации констант. Но если они используются, их смысл должен быть очевиден для читателя. Использование подходящего основания исчисления (10, 8, 16 и пр.) и разделители групп цифр помогут избежать ошибок.

В Аде это сделать легко. Ясный синтаксис позволяет указать любое основание исчисления от 2 до 16 (по умолчанию конечно 10), например 16#2B# это целое число 43 по основанию 16. Символ подчеркивания используется для группировки цифр в значениях с большим количеством разрядов. Так, например, 16#FFFF_FFFF_FFFF_FFFF# вполне читаемая запись значения 2^64^-1.

Для сравнения тот же литерал в C (так же как в C++, Java и пр. родственных языках) выглядит как 0xFFFFFFFFFFFFFFFF, о который не трудно сломать глаза, пытаясь сосчитать сколько F оно содержит. Более того, C трактует лидирующие нули особым образом, в результате число 031 означает совсем не то, что поймет любой школьник, а 25.

Footnotes

Безопасные типы данных

В данной главе речь пойдет не об ускорении набора текста программы, а о механизме, помогающем обнаружить еще больше ошибок и опечаток.

Этот специально разработанный и встроенный в язык механизм часто называют механизмом строгой типизации.

В ранних языках, таких как Fortran и Algol, все обрабатываемые данные имели числовой тип. В конце концов, ведь компьютер изначально способен обращаться только с числами, зачастую закодированными в бинарном виде целыми либо числами с плавающей точкой. В более поздних языках, начиная с Pascal, появилась возможность оперировать объектами на более абстрактном уровне. Так, использование перечислимых типов (в Pascal их называют скалярными) дает нам несомненное преимущество обращаться с цветами, как с цветами, хотя они в итоге будут обрабатываться компьютером, как числа.

Эта идея в языке Ада получила дальнейшее развитие, в то время как другие языки продолжают трактовать скалярные типы, как числовые, упуская ключевую идею абстракции, суть которой в разделении смыслового предназначения и машинного представления.

Использование индивидуальных типов

Допустим, мы наблюдаем за качеством производимой продукции и подсчитываем число испорченных изделий. Для этого мы считаем годные и негодные образцы. Нам нужно остановить производство, если количество негодных образцов привысит некоторый лимит, либо если мы изготовим заданное количество годных изделий. В C и C++ мы могли бы иметь следующие переменные:

int badcount, goodcount;

int b_limit, g_limit;

и далее:

badcount = badcount + 1;

...

if (badcount == b_limit) { ... };

Аналогично для годных образцов. Но, т. к. все это целые числа, ничто не помешает нам случайно написать по ошибке:

if (goodcount == b_limit) { ... };

где нам на самом деле нужно было бы написать g_limit. Это может быть результатом приема «скопировать и вставить», либо просто опечатка (b и g находятся близко на клавиатуре). Как бы то ни было, компилятор будет доволен, а мы — едва ли.

Так может случиться в любом языке. Но в Аде есть способ выразить наши действия более точно. Мы можем написать:

type Goods is new Integer;

type Bads is new Integer;

Эти определения вводят новые типы с теми же характеристиками, что и предопределенный тип Integer (например будут иметь операции + и -). Хотя реализация этих типов ничем не отличается, сами же типы различны. Теперь мы можем написать:

Good_Count, G_Limit : Goods;

Bad_Count, B_Limit : Bads;

Разделив таким образом понятия на две группы, мы достигнем того, что компилятор обнаружит ошибки, когда мы перепутаем сущности разных групп и предотвратит запуск некорректной программы. Следующий код не вызовет нареканий:

Bad_Count := Bad_Count + 1;

if Bad_Count = B_Limit then

Но следующая ошибка будет обнаружена

if Good_Count = B_Limit then --  Illegal

ввиду несовпадения типов.

Когда нам потребуется действительно смешать типы, например, чтобы сравнить количество годных и негодных образцов, мы можем использовать преобразование типов. Например:

if Good_Count = Goods (B_Limit) then

Другим примером может служить вычисление разницы счетчиков образцов:

Diff : Integer := Integer (Good_Count) - Integer (Bad_Count);

Аналогично можно избежать путаницы с типами с плавающей точкой. Например, имея дело с весом и ростом, как в примере из предыдущей главы, вместо того, чтобы писать:

My_Height, My_Weight : Float;

было бы лучше написать:

type Inches is new Float;

type Pounds is new Float;

My_Height : Inches := 68.0;

My_Weight : Pounds := 168.0;

И это позволит компилятору предотвратить путаницу.

Перечисления и целые

В главе «Безопасный синтаксис» мы обсуждали пример с железной дорогой, в котором была следующая проверка:

if (the_signal == clean) { ... }

if The_Signal = Clean then ... end if;

на языке C и Ада соответственно. На C переменная the_signal и соответствующие константы могут быть определены так:

enum signal {

danger,

caution,

clear

};

enum signal the_signal;

Эта удобная запись на самом деле всего лишь сокращение для описания констант danger, caution и clear типа int. И сама переменная the_signal имеет тип int. Как следствие, ничего не помешает нам присвоить переменной the_signal абсолютно бессмысленное значение, например 4. В частности, такие значения могут возникать при использовании не инициализированных переменных. Хуже того, если мы в другой части программы оперируем химическими элементами и используем имена anion, cation, нам ничего не помешает перепутать cation и caution. Мы можем также использовать где-то женские имена betty и clare, либо названия оружия dagger и spear. И снова ничто не предотвратит опечатки типа dagger вместо danger и clare вместо clear.

В Аде мы пишем:

type Signal is (Danger, Caution, Clear);

The_Signal : Signal := Danger;

и путаница исключена, потому, что перечислимый тип в Аде - это совершенно отдельный тип и он не имеет отношения к целому типу. Если мы также где-то имеем:

type Ions is (Anion, Caution);

type Names is (Anne, Betty, Clare, ...);

type Weapons is (Arrow, Bow, Dagger, Spear);

то компилятор предотвратит путаницу этих понятий в момент компиляции. Более того, компилятор не даст присвоить Clear значение Danger, так как оба они литералы и присваивание для них также бессмысленно, как попытка поменять значение литерала 5 написав:

5 := 2 + 2;

На машинном уровне все перечисленные типы кодируются как целые и мы можем получить код для кодировки по умолчанию, используя атрибут Pos, когда нам это действительно необходимо:

Danger_Code : Integer := Signal'Pos (Danger);

Мы также можем ввести свою кодировку. Позже мы остановимся на этом в главе «Безопасная коммуникация».

Между прочим, один из важнейших типов Ады, Boolean, имеет следующее определение:

type Boolean is (False, True);

Результат операций сравнения, таких как The_Signal = Clear имеет тип Boolean. Также существуют предопределенные операции and, or, not для этого типа. В Аде невозможно использовать числовые значение вместо Boolean и наоборот. В то время, как в C, как мы помним, результат сравнения вернет значение целого типа, ноль означает ложно, а не нулевое значение — истинно. Снова возникает опасность в коде:

if (the_signal == clean) { ... }

Как ранее упоминалось, пропустив один знак равенства, вместо выражения сравнения мы получим присваивание. Поскольку целочисленный результат воспринимается в C как значение условия, ошибка остается необнаруженной. Таким образом, данный пример иллюстрирует сразу несколько возможных мест для ошибки:

- использование знака = для присваивания;

- допустимость присваивания там, где ожидается выражение;

- использование числовых значений вместо Boolean в условных выражениях.

Большинство из этого просочилось в C++. Ни одного пункта не присутствует в Аде.

Ограничения и подтипы

Довольно часто значение некоторой переменной должно находится в определенном диапазоне, чтобы иметь какой-то смысл. Хорошо бы иметь возможность обозначить это в программе, выразив, таким образом, наши представления об ограничениях окружающего мира в явном виде. Например, мой вес My_Weight не может быть меньше нуля и, я искренне надеюсь, никогда не привысит 300 фунтов. Таким образом мы можем определить:

My_Weight : Float range 0.0 .. 300.0;

а если мы продвинутые программисты и заранее определили тип Phounds, то:

My_Weight : Phounds range 0.0 .. 300.0;

Далее, если программа ошибочно рассчитает вес, не вписывающийся в заданный диапазон, и попытается присвоить его переменной My_Weight так:

My_Weight := Compute_Weight (...);

то во время исполнения будет возбуждено исключение Constraint_Error. Мы можем перехватить это исключение в каком-то месте программы и предпринять некоторые корректирующие действия. Если мы не сделаем этого, программа завершиться, выдав диагностическое сообщение с указанием, где произошло нарушение ограничения. Все это происходит автоматически — необходимые проверки компилятор сам вставит во всех нужных местах. (Придирчивый читатель, знакомый с языком Ада, заметит, что наша формулировка «программа завершится» нуждается в уточнении, поскольку верна только для последовательных программ. Ситуация в параллельном программировании несколько отличается от описанной, но это выходит за границы темы, обсуждаемой в этой главе.)

Идея ввести поддиапазоны впервые появилась в Pascal и была далее развита в Аде. Она не доступна в других языках, где нам бы пришлось повсюду вписывать свои проверки, и вряд ли мы бы стали этим озадачиваться. Как следствие, любые ошибки, приводящие к нарушению этих границ, становится обнаружить гораздо труднее. Если бы мы знали, что любое значения веса, которым оперирует программа, находится в указанном диапазоне, то вместо того, чтобы добавлять ограничение в определение каждой переменной, мы могли бы наложить его прямо на тип Pounds:

type Pounds is new Float range 0.0 .. 300.0;

С другой стороны, если некоторые значения веса в программе неограничены, а известно лишь, что значение веса человека находится в указанном диапазоне, то мы можем написать:

type Pounds is new Float;

subtype People_Pounds is Pounds range 0.0 .. 300.0;

My_Weight :  People_Pounds;

Аналогично мы можем накладывать ограничения на целочисленные и перечислимые типы. Так, при подсчете образцов мы подразумеваем, что их количество не будет меньше нуля или больше 1000. Тогда мы напишем:

type Goods is new Integer range 0 .. 1000;

Но если мы хотим лишь убедиться, что значения неотрицательные и не хотим накладывать ограничение на верхнюю границу диапазона, то мы напишем:

type Goods is new Integer range 0 .. Integer'Last;

где Integer'Last обозначает наибольшее значение типа Integer. Подмножества положительных и неотрицательных целых чисел используются повсеместно, поэтому для них Ада предоставляет стандартные подтипы:

subtype Natural is Integer range 0 .. Integer'Last;

subtype Positive is Integer range 1 .. Integer'Last;

Можно определить тип Goods:

type Goods is new Natural;

где ограничена только нижняя граница диапазона, что нам и нужно.

Пример ограничения для перечислимого типа может быть следующим:

type Day is (Monday, Tuesday, Wednesday, Thursday,

Friday, Saturday, Sunday);

subtype Weekday is Day range Monday .. Friday;

Далее автоматические проверки предотвратят присваивание Sunday переменным типа Weekday.

Введение ограничений, подобных описанным выше, может показаться утомительным занятием, но это делает программу более понятной. Более того, это позволяет во время компиляции и во время исполнения убедиться, что наши предположения, выраженные в коде, действительно верны.

Предикаты подтипов

Подтипы в Аде очень полезны, они позволяют заранее обнаружить такие ошибки, которые в других языках могут остаться незамеченными и привести затем к краху программы. Но, при всей полезности, механизм подтипов несколько ограничен, т. к. разрешает указывать лишь непрерывные диапазоны значений для числовых и перечислимых типов.

Это подтолкнуло разработчиков языка Ада 2012 ввести предикаты подтипов, которые можно добавлять к определениям типов и подтипов. Как показала практика, необходимо иметь два различных механизма в зависимости от того, является ли предикат статическим или динамическим. Оба используют выражения типа Boolean, но статический предикат разрешает лишь некоторые типы выражений, в то время как динамический применим в более общем случае.

Допустим мы оперируем сезонами года и имеем следующее определение месяцев:

type Month is (Jan, Feb, Mar, Apr, May, Jun,

Jul, Aug, Sep, Oct, Nov, Dec);

Мы хотим иметь отдельные подтипы для каждого сезона. Для северного полушария зима включает декабрь, январь и февраль. (С точки зрения солнцестояния и равноденствия зима длиться с 21 декабря по 21 марта, но, как по мне, март больше относится к весне, чем к зиме, а декабрь ближе к зиме, чем к осени.) Поэтому нам нужен подтип, включающий значения Dec , Jan и Feb. Мы не можем воспользоваться ограничением диапазона здесь, но можем использовать статический предикат следующим образом:

subtype Winter is Month

with Static_Predicate => Winter in Dec | Jan | Feb;

Это гарантирует, что объекты типа Winter могут содержать только Dec , Jan и Feb. Заметьте, что имя подтипа (Winter) в выражении означает текущее значение подтипа.

Подобная синтаксическая конструкция со словом with введена в Ада 2012 и называется аспектом.

Данный аспект проверяется при инициализации переменной по умолчанию, присваивании, преобразовании типа, передаче параметра и т. д. Если проверка не проходит, то возбуждается исключение Assertion_Error. (Мы можем включить или отключить проверку предиката при помощи pragma Assertion_Policy; включает проверку аргумент с именем Check.)

Если условие проверки не является статическим, то необходимо использовать Dynamic_Predicatre аспект. Например:

type T is ...;

function Is_Good (X : T) return Boolean;

subtype Good_T is T

with Dynamic_Predicate => Is_Good (Good_T);

Заметьте, что подтип с предикатом невозможно использовать в некоторых ситуациях, таких как ограничения индекса. Это позволяет избежать таких странных вещей, как массивы «с дырками». Однако подтипы со статическим предикатом можно использовать в for-циклах для перебора всех значений подтипа. Т.е. мы можем написать:

for M in Winter loop ...

В цикле M получит последовательно значения Jan, Feb, Dec, т. е. по порядку определения литералов перечислимого типа.

Массивы и ограничения

Массив - это множество элементов с доступом по индексу. Предположим, что у нас есть пара игральных костей, и мы хотим подсчитать, сколько раз выпало каждое возможное значение (от 2 до 12). Так как всего возможных значений 11, на C мы бы написали:

int counters[11];

int throw;

объявив таким образом 11 переменных с именами от counters[0] до counters[10] и целочисленную переменную throw.

При подсчете очередного значения мы бы написали:

throw = ...;

counters[throw-2] = counters[throw-2] + 1;

Заметьте, что нам пришлось уменьшить значение на 2, т. к. индексы массивов в C всегда отсчитываются от нуля (иначе говоря, нижняя граница массива — всегда ноль). Предположим, что-то пошло не так (или какой-то шутник подсунул нам кость с 7 точками, или используемый нами генератор случайных чисел был неправильно написан) и throw стало равно 13. Что произойдет? Программа на C не обнаружит ошибку. Просто высчитает, где могло бы располагаться counters[11] и прибавит туда единицу. Вероятнее всего, будет увеличено значение переменной throw, т. к. она объявлена сразу после массива. Дальше все пойдет непредсказуемо.

Этот пример демонстрирует печально известную проблему переполнения буфера. Она является причиной множества серьезных и трудно обнаруживаемых неисправностей. В конечном счете это может привести к появлению бреши в защите через которую проходят атаки вирусов на системы, такие как Windows. Мы обсудим это подробнее в главе 7 Безопасное управление памятью.

Давайте теперь рассмотрим аналогичную программу на Аде:

Counters : array (2 .. 12) of Integer;

Throw : Integer;

затем:

Throw := ...;

Counters (Throw) := Counters (Throw) + 1;

Во время исполнения программы на Аде выполняются проверки, запрещающие нам читать/писать элементы за границами массива, поэтому если Throw случайно станет 13, то будет возбуждено исключение Constraint_Error и мы избежим непредсказуемого поведения программы.

Заметим, что в Аде можно определить не только верхнюю, но и нижнюю границу массива. Нет нужды отсчитывать элементы от нуля. Массивы в реальных программах чаще имеют нижнюю границу равную единице, чем нулю. Задав нижнюю границу массива равную двум, мы получаем возможность в качестве индекса использовать непосредственно значение переменной Throw без необходимости вычитать соответствующее смещение, как в C версии.

Настоящая ошибка данной программы случается не в тот момент, когда происходит выход за пределы массива, а когда Throw выходит за корректный диапазон значений. Эту ситуацию можно выявить раньше, если наложить ограничение на Throw:

Throw : Integer range 2 .. 12;

и теперь исключение Constraint_Error будет возбуждено в момент, когда Throw станет 13. Как следствие, компилятор будет в состоянии определить, что значение Throw всегда попадает в границы массива и соответствующие проверки при доступе к массиву не нужны там, где в качестве индекса используется Throw. В итоге, мы можем избавиться от дублирования кода, написав:

subtype Dice_Range is Integer range 2 .. 12;

Throw : Dice_Range;

Counters : array (Dice_Range) of Integer;

Преимущество в том, что если нам в дальнейшем нужно будет поменять диапазон (например, добавив третью кость мы получим значения в диапазоне 3 .. 18), то это нужно будет сделать только в одном месте.

Значение проверок диапазона во время тестирования огромно. Но для программ в промышленной эксплуатации, при желании, эти проверки можно отключить. Подобные проверки применяются не только в Аде. Еще в 1962 компилятор Whetstone Algol 60 мог делать так же. Проверки диапазона определены в стандарте языка (как и в Java, C#).

Наверное стоит упомянуть, что мы можем давать имена и для типов-массивов. Их называют индексируемыми типами. Если у нас есть несколько множеств счетчиков, то будет лучше написать:

type Counter_Array is array (Dice_Range) of Integer;

Counters : Counter_Array;

Old_Counter : Counter_Array;

и затем, когда нам потребуется скопировать все элементы массива Counters в соответствующие элементы массива Old_Counters, мы просто напишем:

Old_Counters := Counters;

Именованные индексируемые типы есть далеко не во всех языках. Преимущество именованных типов в том, что они вводят явную абстракцию, как в примере с подсчетом годных и негодных образцов. Чем больше мы даем компилятору информации о том, что мы хотим сделать, тем больше у него возможностей проверить, что наша программа имеет смысл.

Все объекты типа Counter_Array имеют равное количество элементов, определенное типом Dice_Range. Соответственно такой тип называется ограниченным индексируемым типом. Иногда удобнее определить более гибкий тип для объектов, имеющих одинаковый тип индекса и тип элементов, но различное количество элементов. К примеру:

type Float_Array is array (Positive range <>) of Integer;

Тип Float_Array назвается неограниченным индексируемым типом. При создании объекта такого типа необходимо указать нижнюю и верхнюю границы при помощи ограничения либо задав начальное значение массива.

My_Array : Float_Array (1 .. N);

Любознательный читатель может спросить, что будет если верхняя граница меньше нижней, например, если N равно 0. Это вполне допустимо и приведет к созданию пустого массива. Интересно то, что верхняя граница может быть меньше чем нижняя граница подтипа индекса.

Неограниченные индексируемые типы очень полезны для аргументов, т. к. позволяют писать подпрограммы, обрабатывающие массивы любого размера. Мы рассмотрим примеры позже.

Установка начальных значений по умолчанию

Для устойчивой работы предикатов подтипа (а также инвариантов типа, как мы увидим далее) может потребоваться, чтобы объект при создании имел осмысленное начальное значение. Изначально язык Ада предлагал лишь частичное решение этого вопроса. Для значений ссылочных типов («указателей») гарантированно начальное значение в виде null. Для записей (record) программист может определить значение по умолчанию следующим образом:

type Font is (Arial, Bookman, Times_New_Roman);

type Size is range 1 .. 100;

type Formatted_Character is record

C : Character;

F : Font := Times_New_Roman;

S : Size := 12;

end record;

FC : Formatted_Character;

-- Здесь FC.F = Times_New_Roman, FC.S = 12

-- FC.C не инициализировано

К начальным значениям можно относиться по-разному. Есть мнение, что иметь начальные значения (например, ноль) плохо, поскольку это может затруднить поиск плавающих ошибок. Контраргумент заключается в том, что это дает нам уверенность, что объект имеет согласованное начальное состояние, что может помочь предотвратить разного рода уязвимости.

Как бы то ни было, это довольно странно, что в ранних версиях Ады можно было задать значения по умолчанию для компонент записи, но нельзя было — для скалярных типов или массивов. В версии Ада 2012 это было исправлено при помощи аспектов Default_Value и Default_Component_Value. Новая версия предыдущего примера может выглядеть так:

type Font is (Arial, Bookman, Times_New_Roman)

with Default_Value => Times_New_Roman;

type Size is range 1 .. 100

with Default_Value => 12;

При таком объявлении типов мы можем опустить начальные значения для компонент Formatted_Character:

type Formatted_Character is record

C : Character;

F : Font;    --  Times_New_Roman по умолчанию

S : Size;    --  12 по умолчанию

end record;

Для массива можно указать значение по умолчанию для его компонент:

type Text is new String

with Default_Component_Value =>

Ada.Characters.Latin_1.Space;

Следует заметить, что в отличии от начальных значений компонент записи, здесь используются только статические значения.

«Вещественные ошибки»

Название этого раздела — дословный перевод термина real errors, обозначающего ошибки округления при работе с вещественными числами. В оригинале используется как каламбур.

Для операций над числами с плавающей точкой (используя такие типы, как real в Pascal, float в C и Float в Аде) используется отдельные вычислительные устройства процессора. При этом, само представление числа имеет относительную точность. Так в 32 разрядном слове под мантиссу может быть выделено 23 бита, один бит под знак и 8 бит под экспоненту. Это дает точность 23 двоичных цифры, т. е. примерно 7 десятичных.

При этом для больших чисел, таких как 123456.7 точность будет в одну десятую, а для маленьких, как 0.01234567 — восемь знаков после запятой, но в любом случае число значимых цифр всегда остается 7. Другими словами, точность связана с величиной значения.

Относительная точность подходит во многих случаях, но не во всех. Возьмем к примеру представление угла направления траектории корабля или ракеты. Допустим, мы хотим иметь точность в одну секунду. Полная окружность включает в себя 360 градусов, в каждом градусе 60 минут, в каждой минуте 60 секунд.

Если мы храним угол, как число с плавающей точкой:

float bearing;

тогда для значения 360 градусов точность будет примерно 8 секунд, что недостаточно, в то время как для 1 градуса — точность 1/45 секунды, что излишне. Мы могли бы хранить значение, как целое число секунд, используя целочисленный тип:

int bearingsecs;

Это бы сработало, но нам пришлось бы не забывать выполнять соответствующее масштабирование каждый раз при вводе и отображении значения.

Однако, настоящая проблема чисел с плавающей точкой в том, что точность операций, таких как сложение и вычитание, страдает от ошибок округления. Если мы находим разницу чисел приблизительно одной величины, мы получим существенную потерю точности. К тому же некоторые числа не имеют точного представления. К примеру, у нас есть шаговый двигатель с шагом 1/10 градуса. Мы отмеряем 10 шагов. Но так как 0.1 не имеет точного представления в двоичной форме, в результате мы никогда не получим ровно один градус. Таким образом, даже когда нам не требуется высокая точность, а точность используемого типа больше требуемой, суммарный эффект множества небольших вычислительных погрешностей может быть неограничен.

Ручное масштабирование для использования целочисленных типов допустимо в простых приложениях, но когда у нас несколько таких типов и нам приходится оперировать ими одновременно начинаются проблемы. Ситуация еще более усложняется, если применять для масштабирования более быстрые операции сдвига. Сложность результирующего кода легко может стать причиной ошибок и затрудняет поддержку. Ада среди тех немногих языков, которые предоставляют арифметику с фиксированной точкой. По своей сути, это автоматический вариант масштабирования целых чисел. Так, для шагового мотора мы могли бы определить:

type Angle is delata 0.1 range -360.0 .. 360.0;

for Angle'Small use 0.1;

Результат будет представлен в виде масштабированных (с коэффициентом 0.1) значений, хранимых в виде целых чисел. Но нам удобней думать о них как о соответствующих абстрактных величинах, таких как градусы и их десятые доли. Такая арифметика не страдает от ошибок округления.

Таким образом, Ада имеет две формы для вещественной арифметики:

- числа с плавающей точкой имеющие относительную погрешность;

- числа с фиксированной точкой, имеющие абсолютную погрешность.

Также поддерживается разновидность чисел с фиксированной точкой для десятичной арифметики — стандартная модель для финансовых расчетов.

Тема этого раздела довольно узкоспециализированная, но она иллюстрирует размах возможностей языка Ада и особое внимание к поддержке безопасных численных вычислений.

Footnotes

Безопасные указатели

Первобытный человек совершил гигантский шаг, открыв огонь. Он не только обеспечил себя теплом и едой, но также открыл себе путь к металлическим орудиям труда и далее к индустриальному обществу. Но огонь опасен при небрежном с ним обращении и может стать причиной ужасных бедствий. Для борьбы с диким огнем созданы специальные службы, что служит лишним доказательством серьезности вопроса.

Аналогично, гигантский шаг в разработке программного обеспечения произошел при изобретении понятия указателя или ссылки. Но небрежное обращение с указателями сродни игре с огнем. Указатели приносят неоспоримые преимущества, но при небрежном обращении немедленно следует катастрофа, например, «синий экран смерти», безвозвратная потеря данных, либо брешь в защите, через которую проникают вирусы.

Обычно в программном обеспечении высокой надежности использование указателей существенно ограничено. Ссылочные типы в Аде сочетают семантику указателей со множеством дополнительных ограничений в использовании. Это делает их пригодными для использования повсеместно, быть может, за редким исключением наиболее требовательных к безопасности областей.

Ссылки, указатели и адреса

Вместе с указателями появляются несколько возможностей совершить ошибки, такие как:

- Нарушение типа — создать объект одного типа и получить доступ к нему (через указатель) как если бы он был другого типа. В более общем виде, используя указатель, обратиться к объекту таким способом, что нарушается согласованность с семантическими свойствами этого объекта (например, присвоить значение константе или обойти ограничения диапазона).

- Висячие ссылки — доступ к объекту через указатель после того, как объект перестал существовать Это может быть указатель на локальную переменную после выхода из подпрограммы или на динамически созданный объект, уничтоженный затем через другой указатель.

- Исчерпание свободного пространства — ошибка создания объекта вследствие нехватки ресурсов. Что в свою очередь может быть результатом следующего:

- Созданные объекты становятся недоступными («мусором») и никогда не освобождаются;

- Фрагментация «кучи», когда суммарное количество свободного пространства достаточно, но нет ни одного непрерывного участка нужного размера;

- Необходимый размер «кучи» был недооценен;

- Постоянная утечка (все созданные объекты доступны, но создаются бесконечно, например объекты создаются и добавляются в связный список в бесконечном цикле).

Хотя детали разнятся, нарушения типов и висячие ссылки возможны также и в языках, где есть указатели на подпрограммы.

Исторически в языках применялись различные подходы для решения этих проблем. Ранние языки, такие как Fortran, COBOL и Algol 60 не предоставляли пользователю такое понятие как указатель вообще. Программы на всех языках используют адреса в базовых операциях, таких как вызов подпрограммы, но пользователи этих языков не могли оперировать адресами напрямую.

C (и C++) предоставляют указатели как на объекты созданные в «куче», так и на объекты в стеке, а также на функции. Хотя некоторые проверки все же присутствуют, в основном программист сам должен следить за корректным использованием указателей. Например, т. к. C представляет массив, как указатель на первый элемент и разрешает арифметику над указателями, программист может легко себе создать проблему.

Java и другие «чисто» объектно-ориентированные языки не раскрывают существование указателей приложению, но используют указатели и динамическое создание объектов как базовые понятия языка. Проверка типов сохраняется, и удается избежать висящих ссылок (т. к. нет способа явно вызвать free). Чтобы предотвратить исчерпание «кучи» более недоступными объектами, вводится автоматическая сборка «мусора». Это приемлемо для некоторого класса программ. Но довольно спорно в программах реального времени, особенно в областях требующих высокой надежности и безопасности.

Следует заметить, что «сборка мусора» сама по себе не может защитить от исчерпания свободного пространства: программа добавляющая объекты в связный список в бесконечном цикле в конце концов истратит всю память несмотря на все усилия сборщика мусора. (Бесконечный цикл не обязательно является ошибкой в программе, системы управления процессом и им подобные часто пишутся как программы не имеющие завершения. Для остановки такой программы требуются внешнее влияние, например, чтобы оператор повернул тумблер питания).

Сама история указателей в Аде довольно интересна. Изначально, в версии Ада 83, были доступны только указатели на динамически созданные объекты (т.е. не было указателей на объявленные объекты и на подпрограммы). Также предлагалась явная операция освобождения объектов (Unchecked_Deallocation). Таким образом предотвращалось нарушение типизации и появление висящих указателей на более недоступные локальные объекты. Вместе с тем, оставалась возможность получить висящий указатель при некорректном использовании Unchecked_Deallocation.

Введение Unchecked_Deallocation было неизбежно, так как единственная альтернатива — требовать реализациям предоставлять сборщик мусора — не вписывается в областях вычислений в реальном времени и высокой надежности, где ожидалось широкое распространение языка. Философия Ады такова - любое небезопасное действие должно быть четко обозначено. В самом деле, если мы используем Unchecked_Deallocation, нам необходимо указать его в спецификаторах использования (with Ada.Unchecked_Deallocation;), а затем настроить на нужный тип. (Концепции спецификаторов использования и настраиваемых модулей будет рассмотрена в следующем разделе). Такой сравнительно утяжеленный синтаксис одновременно предотвращает безалаберное использование и облегчает чтение и сопровождение кода, четко выделяя опасные места.

Ада 95 расширяет версию Ада 83 и разрешает иметь указатели на объявленные объекты и на подпрограммы. Версия Ада 2005 идет немного дальше, облегчая передачу указателя на подпрограмму в качестве параметра. Как при этом удается сохранить безопасность мы и рассмотрим в этой главе.

Еще одно замечание до того, как мы углубимся в детали. Поскольку термин указатель часто несет дополнительный низкоуровневый подтекст, в Аде используется термин ссылочный тип. Таким образом, делается акцент на том, что значения ссылочного типа позволяют нам ссылаться на другие объекты некоторого заранее известного типа (и являются своего рода динамическими именами этих объектов) и не должны восприниматься просто как машинный адрес. В самом деле, на уровне реализации представление этих значений могут отличаться от физических указателей.

Ссылочные типы и строгая типизация

Используя возможности языка Ада 2005 мы можем объявить переменную Ref, чьи значения предоставляют доступ к объектам типа T:

Ref : access T;

Если мы не укажем начальное значение, то будет использовано специальное значение null. Ref может ссылаться на обычную переменную типа T (которая, однако, должна быть помечена как aliased):

Obj : aliased T;

...

Ref := Obj'Access;

Это аналогично следующей записи на языке C:

t* ref;

t obj;

ref = &obj;

Тип T в свою очередь может быть определен как:

type Date is record

Day : Integer range 1 .. 31;

Month : Integer range 1 .. 12;

Year : Integer;

end record;

и далее мы можем написать:

Birthday: aliased Date :=(Day => 10, Month => 12, Year => 1815);

AD : access Date := Birthday'Access;

Можно обратиться к отдельным компонентам даты, используя AD:

The_Day : Integer := AD.Day;

Переменная AD также может ссылаться на динамически созданный объект, расположенный «в куче» (которая в Аде носит названия пул /storage pool/).

AD := new Date'(Day => 27, Month => 11, Year => 1852);

(Здесь использованы даты рождения и смерти графини Ады Лавлейс, в честь которой назван язык).

Типичным случаем использования ссылочных типов является связный список. Например, мы можем определить:

type Cell is record

Next : access Cell;

Value : Integer;

end record;

и затем мы сможем создать цепочку объектов типа Cell, связанных в список.

Часто удобно иметь именованный ссылочный тип:

type Date_Ptr is access all Date;

Здесь слово all означает, что этот тип служит для работы как с динамическими созданными объектами, так и с объявленными переменными, расположенными в стеке (которые помечены aliased).

Сама пометка aliased — весьма полезная «страховка». Она предупреждает программиста, что к объекту можно обратиться через ссылку (что помогает при беглом ознакомлении). Кроме того — это сигнал компилятору, что при оптимизации кода нужно учитывать возможность косвенного обращения к объекту через ссылочные значения.

Важным моментом является то, что ссылочный тип всегда связан с типом объектов, на которые он ссылается. Таким образом, всегда выполняется контроль типов при присваивании, передаче параметров и во всех других вариантах использования. Кроме того, ссылочное значение всегда имеет только легальные значения (в числе которых и null). При исполнении программы, при попытке доступа к объекту по ссылке Date_Ptr выполняется проверка, что значение не равно null и возбуждается исключение Constraint_Error, если это не так.

Мы можем явно задать, что ссылочное значение всегда будет отличным от null, записав определение переменной следующим образом:

WD : not null access Date := Wedding_Day'Access;

Естественно, сразу нужно указать начальное значение отличное от null. Использование этой возможности позволяет гарантировать, что упомянутое выше исключение никогда не произойдет.

Наконец, следует отметить, что ссылочное значение может указывать на компоненту составного типа, при условии, что сама компонента помечена как aliased. Например:

A : array (1..10) of aliased Integer := (1,2,3,4,5,6,7,8,9,10);

P : access Integer := A (4)'Access;

Но мы не можем использовать арифметику над ссылочным значением P, такую как P++ или P+1, чтобы обратиться к A (5), как это возможно в C. (На самом деле в Аде нет даже такого оператора, как ++.) Хорошо известно, что подобные действия в C легко приводят к ошибкам, т. к. ничто не мешает нам выйти за границы массива.

Ссылочные типы и контроль доступности

Только что мы рассмотрели, как строгая типизация в языке предотвращает доступ по ссылочному значению к объекту неправильного типа. Следующее требование — убедиться, что объект не прекратит свое существование, пока какой-либо объект ссылочного типа указывает на него. Для случая с определениями объектов это достигается механизмом контроля доступности (accessibility). Рассмотрим следующий код:

package Data is

type Int_Ref is access all Integer;

Ref1 : Int_Ref;

end Data;

with Data; use Data;

procedure P is

K : aliased Integer;

Ref2 : Int_Ref;

begin

Ref2 := K'Access;  --  Illegal

Ref1 := Ref2;

end P;

Хотя это довольно искусственный пример, он в сжатом объеме демонстрирует основные интересные нам места. Пакет Data предоставляет ссылочный тип Int_Ref и объект Ref1 этого типа. Процедура P объявляет локальную переменную K и локальную ссылочную переменную Ref2 также типа Int_Ref. Затем делается попытка присвоить переменной Ref2 ссылку на K. Это запрещено. В самом присвоении Ref2 этого значения проблемы нет потому, что оба объекта (K и Ref2) прекратят свое существование одновременно при завершении вызова процедуры. Настоящая опасность в том, что в дальнейшем мы можем скопировать значение Ref2 в глобальную переменную, в данном случае Ref1, которая будет хранить ссылку на K даже после того, как K перестанет существовать.

Главное правило таково, что время жизни объекта, на который мы получаем ссылку (такого как K) должно быть как минимум такое же, как время жизни указанного ссылочного типа (в нашем случае Int_Ref). В нашем примере это не выполняется, поэтому попытка получить значение, ссылающееся на K незаконна.

Соответствующие правила сформулированы в терминах уровней доступности (accessibility levels), обозначающих вложенность конструкций, охватывающих данное определение. Таким образом, обозначенные правила опираются в основном на статические конструкции языка, проверяются компилятором в момент компиляции и не влекут дополнительных издержек в момент исполнения. Однако правила для параметров подпрограмм, имеющих анонимные ссылочные типы, имеют динамическую природу и проверяются в момент исполнения. Это плата за дополнительную гибкость, которую другим способом достичь не удается.

В столь коротком обзоре языка как этот, у нас нет возможности еще больше углубиться в детали. Достаточно сказать, что правила контроля доступности предотвращают висящие ссылки на объявляемые объекты, которые являются источником множества коварных и трудно устранимых ошибок в других «дырявых» языках.

Ссылки на подпрограммы

В Аде разрешены ссылки на процедуры и функции. Работают они аналогично ссылкам на объекты. Соответственно для них также выполняются проверки строгой типизации и контроль доступности. Например, используя возможности Ады 2005, мы можем написать:

A_Func : access function (X : Float) return Float;

После этого объект A_Func может хранить ссылки только на функции с параметром типа Float и возвращающие Float (такова, к примеру, предопределенная функция Sqrt).

И так мы можем написать:

A_Func := Sqrt'Access;

...

X : Float := A_Func (4.0);  --  косвенный вызов

Это приведет к вызову функции Sqrt с аргументом 4.0, а результат, видимо, будет 2.0.

Язык тщательно следит за совпадением параметров, поэтому мы не можем вызвать функцию с неверным количеством/типом параметров. Это же верно и для результата функции. Список параметров и результат функции составляют отдельное понятие, техническое название которого — профиль функции.

Теперь рассмотрим предопределенную функцию вычисления арктангенса Arctan. Она имеет два параметра и возвращает угол θ (в радианах) такой, что tan θ = Y/X.

function Arctan (X : Float; Y : Float) return Float;

Если мы напишем:

A_Func := Arctan'Access;  -- Ошибка

Z := A_Func (A);  --  косвенный вызов предотвращен

Компилятор отвергнет такой код потому, что профиль функции Arctan не совпадает с профилем A_Func. Это как раз то, что нужно, иначе функция Arctan достала бы два аргумента из стека, в то время как косвенный вызов по ссылке A_Func положит в стек лишь один аргумент (Это, на самом деле, зависит от ABI аппаратной платформы, не факт, что floats будут передаваться через стек). Результат получился бы совершенно бессмысленным.

Соответствующие проверки выполняются независимо от пересечения границ модулей компиляции (модули компиляции — программные единицы, компилируемые раздельно, мы остановимся на этом в главе «Безопасная архитектура»). Аналогичные проверки в С не работают в этом случае, что часто приводит к серьезным проблемам.

Более сложный случай возникает, когда одна подпрограмма передается в другую как параметр. Допустим, у нас есть функция для решения уравнения Fn(X) = 0, причем функция Fn сама передается как параметр:

function Solve (Trial : Float;

Accuracy : Float;

Fn : access function (X : Float) return Float)

return Float;

Параметр Trial — это первое приближение, параметр Accuracy — требуемая точность, третий параметр Fn — функция из уравнения.

К примеру, мы инвестировали 1000 долларов сегодня и 500 долларов в течении года, какова должна быть процентная ставка, чтобы конечная чистая стоимость за два года была в точности 2000 долларов? Задавая процентную ставку как X, мы можем вычислить конечную чистую стоимость по формуле:

Nfv (X) = 1000 * (1 + X/100)2 + 500 * (1 + X/100)

Чтобы ответить на вопрос, определим функцию, которая вернет 0.0 когда стоимость достигнет 2000.0:

function Nvf_2000 (X : Float) return Float is

Factor : constant Float := 1.0 + X / 100.0;

begin

return 1000.0 * Factor ** 2 + 500.0 * Factor - 2000.0;

end Nvf_2000;

Затем можно сделать:

Answer : Float := Solve

(Trial => 5.0, Accuracy => 0.01, Fn => Nvf_2000'Access);

Мы предлагаем решить уравнение, указав первое приближение в 5%, точность 0.01 и целевую функцию Nvf_2000. Предлагаем читателю найти решение, наше значение вы найдете в конце главы. (Термин «конечная чистая стоимость» хорошо известен финансовым специалистам.)

Мы хотели бы отметить, что в Аде будут проверяться типы параметров функции, даже когда она сама передается как параметр, благодаря тому, что профиль функции может иметь произвольную глубину вложенности. Многие языки имеют ограничение в один уровень.

Заметим, что параметр Fn имеет анонимный тип. Аналогично ссылкам на объекты, мы можем определить именованный ссылочный тип для подпрограмм. И можем заставить ссылочный тип хранить только не null значения. Т.е. можно написать:

A_Func : not null access function (X : Float) return Float

:= Sqrt'Access;

Плюс тут в том, что мы явно гарантируем, что A_Func не равен null в любом месте, где бы мы его не использовали.

В том случае, если Вы считаете использование произвольной функции (в данном случае Sqrt), как начального значения не равного null безвкусицей, можно определить специальную функцию для значения по умолчанию:

function Default (X : Float) return Float is

begin

Put ("Value not set");

return 0.0;

end Default;

...

A_Func : not null access function (X : Float) return Float

:= Default'Access;

Аналогично, нам необходимо добавить not null в профиль функции Solve:

function Solve

(Trial : Float;

Accuracy : Float;

Fn : not null access function (X : Float) return Float)

return Float;

Это гарантирует что аргумент Fn никогда не будет null.

Вложенные подпрограммы в качестве параметров

Как мы упоминали ранее, контроль доступности также работает и для ссылок на подпрограммы. Допустим функция Solve определена в пакете и использует именованный ссылочный тип для параметра Fn:

package Algorithms is

type A_Function is

not null access function (X : Float) return Float;

function Solve

(Trial : Float; Accuracy : Float; Fn : A_Function)

return Float;

...

end Algorithms;

Допустим мы хотим обобщить пример с вычислением чистой стоимости, чтобы иметь возможность передавать целевое значение как параметр. Попробуем так:

with Algorithms; use Algorithms;

function Compute_Iterest (Target : Float) return Float is

function Nfv_T (X : Float) return Float is

Factor : constant Float := 1.0 + X/100.0;

begin

return 1000.0*Factor**2 + 500.0*Factor - Target;

end Nfv_T;

begin

return Solve (Trial => 5.0, Accuracy => 0.01,

Fn => Nfv_T'Access);  --  Illegal

end Compute_Iterest;

Однако Nfv_T'Access нельзя использовать как значение параметра Fn, потому, что это нарушает правила контроля доступности. Проблема в том, что функция Nfv_T находится на более глубоком уровне вложенности, чем тип A_Function. (Так и должно быть, поскольку нам необходим доступ к параметру Target.) Если бы подобное было разрешено, мы могли бы присвоить это значение какой-нибудь глобальной переменной типа A_Function. После выхода из функции Compute_Interest функция Nfv_T будет недоступна для использования, но глобальная переменная все еще будет хранить ссылку на нее. Например:

Dodgy_Fn : A_Function := Default'Access; --  Глобальный объект

function Compute_Iterest (Target : Float) return Float is

function Nfv_T (X : Float) return Float is

...

end Nfv_T;

begin

Dodgy_Fn := Nfv_T'Access;  --  Ошибка

...

end Compute_Iterest;

После завершения вызова мы делаем:

Answer := Dodgy_Fn (99.9); --  результат непредсказуем

Вызов Dodgy_Fn будет пытаться вызвать Nfv_T, но это невозможно, потому, что она локальна для Compute_Interest и будет пытаться обратиться к параметру Target, которого уже не существует. Если бы Ада не запрещала это делать, последствия были бы непредсказуемы. Заметьте, что при использовании анонимного типа для параметра Fn, мы могли бы передать вложенную функцию, как аргумент Solve, но тогда контроль доступности сработал бы при попытке присвоить это значение переменной Dodgy_Fn. Во время исполнения выполнилась бы проверка, что уровень вложенности Nfv_T больше, чем уровень вложенности типа A_Function и произошло бы возбуждение исключения Program_Error. Таким образом, правильным решением было бы определить:

package Algorithms is

function Solve

(Trial : Float;

Accuracy : Float;

Fn : not null access function (X : Float)

return Float)

return Float;

end Algorithms;

и оставить функцию Compute_Interest в первоначальном варианте (удалив комментарий Ошибка, конечно).

Может показаться, что проблема лежит в том, что функция Nfv_T вложена в Compute_Iterest. Мы могли бы сделать ее глобальной и проблемы с доступностью исчезли бы. Но для этого нам пришлось бы передавать значение Target через какую-нибудь переменную в пакете верхнего уровня, в стиле COMMON-блоков языка FORTRAN. Мы не можем добавить ее в список параметров функции, т. к. список параметров должен совпадать со списком для Fn. Но передавать данные через глобальные переменные фактически порочная практика. Она нарушает принцип сокрытия информации, принцип абстракции, а также плохо стыкуется с многозадачностью. Заметим, что практика использования вложенных функций, когда функция получает доступ к нелокальным переменным (таким как Target) часто называется «замыканием».

Такие замыкания, другими словами передача указателя на вложенную подпрограмму как параметр времени исполнения, используются в некоторых местах стандартной библиотеки Ады, например для перебора элементов какого-нибудь контейнера.

Использовать вложенные подпрограммы в таких случаях естественно, т. к. они нуждаются в нелокальных данных. Подобный подход затруднен в «плоских» языках программирования, таких как C, C++ и Java. В некоторых случаях можно использовать механизм наследования, но он менее ясен, что может повлечь проблемы при сопровождении кода.

Наконец, может потребоваться комбинировать алгоритмы, используя вложенность. Так, наш пакет Algorithms может содержать другие полезные вещи:

package Algorithms is

function Solve

(Trial : Float;

Accuracy : Float;

Fn : not null access function (X : Float)

return Float)

return Float;

function Integrate

(Lo, Hi : Float;

Accuracy : Float;

Fn : not null access function (X : Float)

return Float)

return Float;

type Vector is array (Positive range <>) of Float;

procedure Minimize

(V : in out Vector; Accuracy : Float;

Fn : not null access function (V : Vector)

return Float)

return Float;

end Algorithms;

Функция Integrate подобна Solve. Она вычисляет определённый интеграл от данной функции на заданном интервале. Процедура Minimize несколько отличается. Она находит те значения элементов массива, на которых данная функция достигает минимума. Возможна ситуация, когда целевая функция минимизации является интегралом и использует V. Кому-то это может показаться притянутым за уши, но автор потратил первые несколько лет своей карьеры программиста, работая над подобными вещами в химической индустрии.

Код может иметь вид:

with Algorithms; use Algorithms;

procedure Do_It is

function Cost (V: Vector) return Float is

function F (X : Float) return Float is

Result : Float;

begin

... --  Вычислим Result используя V и X

return Float;

end F;

begin

return Integrate (0.0, 1.0, 0.01, F'Access);

end Cost;

A : Vector (1 .. 10);

begin

... -- perhaps read in or set trial values for the vector A

Minimize (A, 0.01, Cost'Access);

... -- output final values of the vector A

end Do_It;

В Аде 2005 (и соответственно в Аде 2012) подобный подход срабатывает «на ура», как если бы вы делали это на Algol 60. В других языках подобное сделать трудно, либо требует использования небезопасных конструкций, которые могут привести к появлению висящих ссылок.

Дополнительные примеры использования ссылочных типов для подпрограмм можно найти в главе «Безопасная коммуникация».

И, наконец, искомая процентная ставка при которой 1000 долларов инвестиций с последующими 500 долларами за два года дадут 2000 чистой стоимости равна 18.6%. И это круто!

Footnotes

Безопасная архитектура

Если говорить о строительстве, то хорошей архитектурой считается та, что гарантирует требуемую прочность самым естественным и простейшим путем, предоставляя людям безопасную среду обитания. Красивым примером может служить Пантеон в Риме, чья сферическая форма обладает чрезвычайной прочностью и в тоже время предоставляет максимум свободного пространства. Многие кафедральные соборы не так хороши и нуждаются в дополнительных колоннах снаружи для поддержки стен. В 1624г. сэр Ганри Вутон подытожил эту тему следующими словами: «хорошее строение удовлетворяет трем условиям - удобство, прочность и красота».

Аналогично, хорошая архитектура в программировании должна обеспечивать безопасность функционирования отдельных компонент простейшим образом, при этом сохраняя прозрачность системы в целом. Она должна обеспечивать взаимодействие, где это необходимо, и препятствовать взаимному влиянию действий, не связанных друг с другом. Хороший язык программирования должен позволять писать эстетически красивые программы с хорошей архитектурой.

Возможно, здесь есть аналогия с архитектурой офисных помещений. Если выделить каждому отдельный кабинет, это будет препятствовать общению и обмену идеями. С другой стороны, полностью открытое пространство приведет к тому, что шум и другие отвлекающие факторы будут препятствовать продуктивной работе.

Структура программ на Аде базируется на идее пакетов, которые позволяют сгруппировать взаимосвязанные понятия и предоставляют очевидный способ сокрытия деталей реализации.

Спецификация и тело пакета

Ранние языки программирования, такие как FORTRAN, имели плоскую структуру, где все располагалось, в основном, на одном уровне. Как следствие, все данные (не считая локальных данных подпрограммы) были видимы всюду. Это похоже на единое открытое пространство в офисе. Похожую плоскую модель предлагает и язык C, хотя и предлагает некоторую дополнительную возможность инкапсуляции, предоставляя программисту возможность контролировать видимость подпрограмм за границами текущего файла.

Другие языки, например Algol и Pascal, имеют простую вложенную блочную структуру, напоминающую матрешку. Это немного лучше, но все равно напоминает единое открытое пространство, поделенное на отдельные мелкие офисы. Проблема взаимодействия все равно остается.

Рассмотрим стек из чисел в качестве простого примера. Мы хотим иметь протокол, позволяющий добавить элемент в стек, используя вызов процедуры Push, и удалить верхний элемент, используя функцию Pop. И, допустим, еще одну процедуру Clear для сброса стека в пустое состояние. Мы намерены предотвратить все другие способы модификации стека, чтобы сделать данный протокол независимым от метода его реализации.

Рассмотрим реализацию, написанную на Pascal-е. Для хранения данных используется массив, а для работы написаны три подпрограммы. Константа max ограничивает максимальный размер стека. Это позволяет нам избежать дублирования числа 100 в нескольких местах, на тот случай, если нам потребуется его изменить.

const max = 100;

var    top : 0 .. max;

a : array [1..max] of real;

procedure Clear;

begin

top := 0

end;

procedure Push(x : real);

begin

top := top + 1;

a[top] := x

end;

function Pop : real;

begin

top := top - 1;

Pop := a[top+1]

end;

Главная проблема тут в том, что max, top и a должны быть объявлены вне подпрограмм Push, Pop и Clear, чтобы мы могли иметь доступ к ним. Как следствие, в любом месте программы, где мы можем вызвать Push, Pop и Clear, мы также можем непосредственно поменять top и a, обойдя, таким образом протокол использования стека и получить несогласованное состояние стека.

Это может служить источником проблем. Если нам захочется вести учет количества изменений стека, то просто добавить счетчик в процедуры Push, Pop и Clear может оказаться недостаточно. При анализе большой программы, когда нам нужно найти все места, где стек изменялся, нам нужно отследить не только вызовы Push, Pop и Clear, но и обращения к переменным top и a.

Аналогичная проблема существует и в C и в Fortran. Эти языки пытаются ее преодолеть, используя механизм раздельной компиляции. Объекты, видимые из других единиц компиляции, помечаются специальной инструкцией extern либо при помощи заголовочного файла. Однако, проверка типов при пересечении границ модулей компиляции в этих языках работает гораздо хуже.

Язык Ада предлагает использовать механизм пакетов, чтобы защитить данные, используемые в Push, Pop и Clear от доступа извне. Пакет делится на две части — спецификацию, где описывается интерфейс доступный из других модулей, и тело, где располагается реализация. Другими словами, спецификация задает что делать, а тело — как это делать. Спецификация стека могла бы быть следующей:

package Stack is

procedure Clear;

procedure Push (X : Float);

function Pop return Float;

end Stack;

Здесь описан интерфейс с внешним миром. Т.е. вне пакета доступны лишь три подпрограммы. Этой информации достаточно программисту, чтобы вызывать нужные подпрограммы, и достаточно компилятору, чтобы эти вызовы скомпилировать. Тело пакета может иметь следующий вид:

package body Stack is

Max : constant := 100;

Top : Integer range 0 .. Max := 0;

A : array (1 .. Max) of Float;

procedure Clear is

begin

Top := 0;

end Clear;

procedure Push (X : Float) is

begin

Top := Top + 1;

A (Top) := X;

end Push;

function Pop return Float is

begin

Top := Top - 1;

return A (Top + 1);

end Pop;

end Stack;

Тело содержит полный текст подпрограмм, а также определяет скрытые объекты Max, Top и A. Заметьте, что начальное значение Top равняется нулю.

Для того, чтобы использовать сущности, описанные в пакете, клиентский код должен указать пакет в спецификаторе контекста (с помощью зарезервированного слова with) следующим образом:

with Stack;

procedure Some_Client is

F : Float;

begin

Stack.Clear;

Stack.Push (37.4);

...

F := Stack.Pop;

...

Stack.Top := 5; -- Ошибка!

end Some_Client;

Теперь мы уверены, что требуемый протокол будет соблюден. Клиент (программный код, использующий пакет) не может ни случайно, ни намеренно взаимодействовать с деталями реализации стека. В частности, прямое присваивание значения Stack.Top запрещено, поскольку переменная Top не видима для клиента (т. к. о ней нет упоминания в спецификации пакета).

Обратите внимание на три составляющие этого примера: спецификацию пакета, тело пакета и клиента.

Существуют важные правила, касающиеся их компиляции. Клиент не может быть скомпилирован пока не будет предоставлена спецификация. Тело также не может быть скомпилировано без спецификации. Но подобных ограничений нет между телом и клиентом. Если мы решим изменить детали реализации и это не затрагивает спецификацию, то в перекомпиляции клиента нет нужды.

Пакеты и подпрограммы верхнего уровня (т. е. не вложенные в другие подпрограммы) могут быть скомпилированы раздельно. Их обычно называют библиотечными модулями и говорят, что они находятся на уровне библиотеки.

Заметим, что пакет Stack упоминается каждый раз при обращении к его сущностям. В результате в коде клиента наглядно видно, что происходит. Но если постоянное повторение имени пакета напрягает, можно использовать спецификатор использования (с помощью служебного слова use):

with Stack; use Stack;

procedure Client is

begin

Clear;

Push (37.4);

...

end Client;

Однако, если используются два пакета, например Stack1 и Stack2, каждый из которых определяют подпрограмму Clear, и мы используем with и use для обоих, то код будет неоднозначным и компилятор не примет его. В этом случае достаточно указать необходимый пакет явно, например Stack2.Clear.

Подытожим вышесказанное. Спецификация определяет контракт между клиентом и пакетом. Тело пакета обязано реализовать спецификацию, а клиент обязан использовать пакет только указанным в спецификации образом. Компилятор проверяет, что эти обязательства выполняются. Мы вернемся к этому принципу позже в данной главе, а также в последней главе, когда рассмотрим поддержку контрактного программирования в Аде 2012 и идеи, лежащие в основе инструментария SPARK соответственно.

Дотошный читатель отметит, что мы полностью игнорировали ситуации переполнения (вызов Push при Top = Max) и исчерпания (вызов Pop при Top = 0) стека. Если одна из подобных неприятностей случиться, сработает проверка диапазона значения Top и будет возбужденно исключение Constraint_Error. Было бы хорошо включить предусловия для вызова подпрограмм Push и Pop в их спецификацию в явном виде. Тогда при использовании пакета программист бы знал, чего ожидать от вызова подпрограмм. Такая возможность появилась в Ада 2012, как часть поддержки технологии контрактного программирования, мы далее обсудим это.

Исключительно важным моментом здесь является то, что в Аде контроль строгой типизации не ограничен границами модулей компиляции. Написана ли программа как один компилируемый модуль или состоит из нескольких модулей, поделенных на разные файлы, производимые проверки будут совпадать в точности.

Приватные типы

Еще одна возможность пакета позволяет спрятать часть спецификации от клиента. Это делается при помощи так называемой приватной части. В примере выше пакет Stack реализует лишь один стек. Возможно, будет полезнее написать такой пакет, чтобы он позволял определить множество стеков. Чтобы достичь этого, нам нужно ввести понятие стекового типа. Мы могли бы написать

package Stacks is

type Stack is private;

procedure Clear (S : out Stack);

procedure Push (S : in out Stack; X : in Float);

procedure Pop (S : in out Stack; X : out Float);

private

Max : constant := 100;

type Vector is array (1 .. 100) of Float;

type Stack is record

A : Vector;

Top : Integer range 0 .. Max := 0;

end record;

end Stacks;

Это очевидное обобщение одно-стековой версии. Но стоит отметить, что в Аде 2012 появляется выбор, описать Pop либо как функцию, возвращающую Float, либо как процедуру с out параметром типа Float. Это возможно т. к., начиная с версии Ада 2012, функции могут иметь out и in out параметры. Несмотря на это, мы последовали традиционным путем и записали Pop как процедуру. По стилю вызовы Pop и Push будут единообразны, и тот факт, что вызов Pop имеет побочный эффект, будет более очевиден.

Тело пакета может выглядеть следующим образом:

package body Stacks is

procedure Clear (S : out Stack) is

begin

S.Top := 0;

end Clear;

procedure Push (S : in out Stack; X : in Float) is

begin

S.Top := S.Top + 1;

S.A (S.Top) := X;

end Push;

--  процедура Pop аналогично

end Stacks;

Теперь клиент может определить, сколько угодно стеков и работать с ними независимо:

with Stacks; use Stacks;

procedure Main is

This_Stack : Stack;

That_Stack : Stack;

begin

Clear (This_Stack); Clear (That_Stack);

Push (This_Stack, 37.4);

...

end Main;

Подробная информация о типе Stack дается в приватной части пакета и, хотя она видима читателю, прямой доступ к ней из кода клиента отсутствует. Таким образом, спецификация логически разделяется на две части — видимую (все что перед private) и приватную.

Изменения приватной части не приводят к необходимости исправлять исходный код клиента, однако модуль клиента должен быть перекомпилирован, поскольку его объектный код может измениться, хотя исходный текст и останется тем же.

Все необходимые перекомпиляции контролируются системой сборки и по желанию выполняются автоматически. Следует подчеркнуть, что это требования спецификации языка Ада, а не просто особенности конкретной реализации. Пользователю никогда не придется решать, нужно ли перекомпилировать модуль, таким образом, нет риска построить программу из несогласованных версий компилируемых модулей. Это большая проблема для языков, у которых нет точного механизма взаимодействия компилятора, системы сборки и редактора связей.

Также отметьте синтаксис указания режима параметров in, out и in out. Мы остановимся на них подробнее в главе «Безопасное создание объектов», где будет описана концепция потоков информации (information/data flow).

Контрактная модель настраиваемых модулей

Шаблоны — одна из важных возможностей таких языков программирования как C++ (а также недавно Java и C#). Им в Аде соответствуют настраиваемые модули (настраиваемые/обобщенные пакеты, generic packages). На самом деле, при создании шаблонов C++ были использованы идеи настраиваемых модулей Ады. Чтобы обеспечить безопасность типов данных, настраиваемые модули используют так называемую контрактную модель.

Мы можем расширить пример со стеком так, чтобы стало возможно определить стеки для произвольных типов и размеров (позже мы рассмотрим еще один способ сделать это). Рассмотрим следующий код

generic

Max : Integer;

type Item is private;

package Generic_Stacks is

type Stack is private;

procedure Clear (S : out Stack);

procedure Push (S : in out Stack; X : in Item);

procedure Pop (S : in out Stack; X : out Item);

private

type Vector is array (1 .. 100) of Item;

type Stack is record

A : Vector;

Top : Integer range 0 .. Max := 0;

end record;

end Generic_Stacks;

Тело к этому пакету можно получить из предыдущего примера, заменив Float на Item.

Настраиваемый пакет - это просто шаблон. Чтобы использовать его в программе, нужно сначала выполнить его настройку, предоставив два параметра — Max и Item. В результате настройки получается реальный пакет. К примеру, если мы хотим работать со стеками целых чисел с максимальным размером 50 элементов, мы напишем:

package Integer_Stacks is new Generic_Stacks

(Max => 50, Item => Integer);

Эта запись определяет пакет Integer_Stacks, который далее можно использовать как обычный. Суть контрактной модели в том, что если мы предоставляем параметры, отвечающие требованиям описания настраиваемого пакета, то при настройке мы гарантированно получим рабочий пакет, компилируемый без ошибок.

Другие языки не предоставляют этой привлекательной возможности. В C++, к примеру, некоторые несоответствия можно выявить только в момент сборки программы, а некоторые и вовсе могут остаться не обнаруженными, пока мы не запустим программу и не получим исключение.

Существуют разнообразные варианты настраиваемых параметров в языке Ада. Использованная ранее форма:

type Item is private;

позволяет использовать практически любой тип для настройки. Другая форма:

type Item is (<>);

обозначает любой скалярный тип. Сюда относятся целочисленные типы (такие как Integer и Long_Integer) и перечислимые типы (такие как Signal). Внутри настраиваемого модуля мы можем пользоваться всеми свойствами, общими для этих типов, и, несомненно, любой актуальный тип будет иметь эти свойства.

Контрактная модель настраиваемых модулей очень важна. Она позволяет вести разработку библиотек общего назначения легко и безопасно. Это достигается во многом благодаря тому, что пользователю нет необходимости разбираться с деталями реализации пакета, чтобы определить, что может пойти не так.

Дочерние модули

Общая архитектура системы (программы) на языке Ада может иметь иерархическую (древовидную) структуру, что облегчает сокрытие информации и упрощает модификацию. Дочерние модули могут быть общедоступными или приватными. Имея пакет с именем Parent мы можем определить общедоступный дочерний пакет следующим образом:

package Parent.Child is ...

а приватный как:

private package Parent.Child is ...

Оба варианта могут иметь тело и приватную часть, как обычно. Ключевая разница в том, что общедоступный дочерний модуль, по сути, расширяет спецификацию родителя (и таким образом видим всем клиентам), тогда как приватный модуль расширяет приватную часть и тело родителя (и таким образом не видим клиентам). У дочерних пакетов, в свою очередь, могут быть дочерние пакеты и так далее.

Среди правил, определяющих видимость имен, можно отметить следующее. Дочерний модуль не нуждается в спецификаторе контекста (with Parent), чтобы видеть объекты родителя. В тоже время, тело родителя может иметь спецификатор контекста для дочернего модуля, если нуждается в функциональности, предоставляемой им. Однако, поскольку спецификация родителя должна быть доступна к моменту компиляции дочернего модуля, спецификация родителя не может содержать «обычный» спецификатор контекста (with Child) для дочернего модуля. Мы обсудим это позже.

Согласно другому правилу, из видимой части приватного модуля видна приватная часть его родителя (в точности, как это происходит в теле пакета-родителя). Эта «дополнительная» видимость не нарушает родительскую инкапсуляцию, поскольку использовать приватные модули могут только те модули, которые и так видят приватную часть родителя. С другой стороны, в общедоступном модуле приватную часть родителя видно только из его приватной части и тела. Это обеспечивает инкапсуляцию данных родителя.

Особая форма спецификации контекста private with, которая была добавлена в Аде 2005, обеспечивает видимость перечисленных модулей в приватной части пакета. Это полезно, когда приватная часть общедоступного дочернего пакета нуждается в информации, предоставляемой приватным дочерним модулем. Допустим, у нас есть прикладной пакет App и два дочерних App.User_View и App.Secret_Details:

private package App.Secret_Details is

type Inner is ...

...  -- различные операции для типа Inner

end App.Secret_Details;

private with App.Secret_Details;

package App.User_View is

type Outer is private;

...     -- различные операции для типа Outer

-- тип Inner не видим здесь

private

type Outer is record

X : App.Secret_Details.Inner;

...

end record;

...

end App.User_View;

Обычный спецификатор контекста (with App.Secret_Details;) не допустим в User_View, поскольку это бы позволило клиенту увидеть информацию из пакета Secret_Details через видимую часть пакета User_View. Все попытки обойти правила видимости в Аде тщательно заблокированы.

Модульное тестирование

Одна из проблем, встречающаяся при тестировании кода, заключается в том, чтобы предотвратить влияние тестов на поведение тестируемого кода. Это напоминает известный феномен квантовой механики, когда сама попытка наблюдения за такими частицами, как электрон, влияет на состояние этой частицы.

Тщательно разрабатывая архитектуру программного обеспечения, мы стараемся скрыть детали реализации, сохранив стройную абстракцию, например, используя приватные типы. Но при тестировании системы мы хотим иметь возможность тщательно проанализировать поведение скрытых деталей реализаций.

В качестве простейшего примера, мы хотим знать значение Top одного из стеков, объявленных с помощью пакета Stacks (в котором находится приватный тип Stack). У нас нет готовых средств сделать это. Мы могли бы добавить функцию Size в пакет Stacks, но это потребует модификации пакета и перекомпиляции пакета и всего клиентского кода. Возникает опасность внести ошибку в пакет при добавлении этой функции, либо позже, при удалении тестирующего кода (и это будет гораздо хуже).

Дочерние модули позволяют решить эту задачу легко и безопасно. Мы можем написать следующее

package Stacks.Monitor is

function Size (S : Size) return Integer;

end Stacks.Monitor;

package body Stacks.Monitor is

function Size (S : Size) return Integer is

begin

return S.Top;

end Size;

end Stacks.Monitor;

Это возможно, так как тело дочернего модуля видит приватную часть родительского пакета. Теперь в тестах мы можем вызвать функцию Size как только нам понадобится. Когда мы убедимся, что наша программа корректна, мы удалим дочерний пакет целиком. Родительский пакет при этом не будет затронут.

Взаимозависимые типы

Эквивалент приватных типов есть во многих языках программирования, особенно в области ООП. По сути, операции, принадлежащие типу, это те, что объявлены рядом с типом в одном пакете. Для типа Stack такими операциями являются Clear, Push и Pop. Аналогичная конструкция в C++ выглядит так:

class Stack {

...   /* детали реализации стека */

public:

void Clear();

void Push(float);

float Pop();

};

Подход C++ удобен тем, что использует один уровень при именовании — Stack, в то время, как в Аде мы используем два - имя пакета и имя типа, т.е. Stacks.Stack. Однако, этого, при желании, легко избежать, используя спецификатор использования — use Stacks. И, более того, появляется возможность выбора предпочитаемого стиля. Можно, например, назвать тип нейтрально — Object или Data, а затем ссылаться на него написав Stacks.Object или Stacks.Data.

С другой стороны, если в двух типах мы желаем для реализации использовать общую информацию, на языке Ада это может быть легко достигнуто:

package Twins is

type Dum is private;

type Dee is private;

...

private

...   --  Общая информация для реализации

end Twins;

где в приватной части мы определим Dum и Dee так, что они будут иметь свободный взаимный доступ к данным друг друга.

В других языках это может быть не так просто. Например, в C++ нужно использовать довольно спорный механизм friend. Подход, используемый в Аде, предотвращает некорректное использование данных и раскрытие данных реализации и является при этом симметричным.

Следующий пример демонстрирует взаимную рекурсию. Допустим, мы исследуем схемы из линий и точек, при этом каждая точка лежит на пересечении трех линий, а каждая линия проходит через три точки. (Это пример на самом деле не случаен, две из фундаментальных теорем проективной геометрии оперируют такими структурами). Это легко реализовать в одном пакете, используя ссылочные типы:

package Points_And_Lines is

type Point is private;

type Line is private;

...

private

type Point is record

L, M, N : access Line;

end record;

type Line is record

P, Q, R : access Point;

end record;

end Points_And_Lines;

Если мы решим расположить каждый тип в своем пакете, это тоже возможно, но необходимо использовать специальную форму спецификатора контекста limited with, введенную в стандарте Ada 2005. (Два пакета не могут ссылаться друг на друга, используя обычный with, потому, что это вызовет циклическую зависимость между ними при инициализации). Мы напишем:

limited with Lines;

package Points is

type Point is private;

...

private

type Point is record

L, M, N : access Lines.Line;

end record;

end Points;

и аналогичный пакет для Lines. Данная форма спецификатора контекста обеспечивает видимость неполным описаниям типов из данного пакета. Грубо говоря, такая видимость пригодна лишь для использования в ссылочных типах.

Контрактное программирование

В примере со стеком, рассмотренном нами ранее, есть некоторые недочеты. Хотя он прекрасно иллюстрирует использование приватных типов для сокрытия деталей реализации, ничто в спецификации пакета не отражает того, что мы реализуем стек. Несмотря на то, что мы тщательно выбрали имена для операций со стеком, такие как Push, Pop и Clear, некто (по ошибке или злонамеренно) может использовать Push для извлечения элементов, а Pop — для их добавления. В целях повышения надежности и безопасности было бы полезно иметь механизм, который учитывает намерения автора в контексте семантики типа и подпрограмм, объявленных в пакете.

Такие средства были добавлены в стандарт Ада 2012. Они аналогичны предлагаемым в Eiffel средствам конрактного программирования. Воспользовавшись ими, программист указывает пред- и пост-условия для подпрограмм и инварианты приватных типов. Эти конструкции имеют форму логических условий. Специальные директивы компилятору включают проверку этих условий в момент исполнения. Чтобы привязать эти конструкции к соответствующему имени (пред/пост-условия к подпрограммам и инварианты к типам), используется новый синтаксис спецификации аспекта. Вкратце:

- Пред-условие проверяется в точке вызова подпрограммы и отражает обязательства вызывающего;

- Пост-условие проверяется при возврате из подпрограммы и отражает обязательства вызываемой подпрограммы;

- Инвариант типа эквивалентен пост-условию для каждой подпрограммы типа, видимой вне пакета, поэтому проверяется при выходе из каждой такой подпрограммы. Инвариант отражает «глобальное» состояние программы после выхода из любой такой подпрограммы.

Представленная ниже версия пакета Stacks иллюстрирует все три концепции. Чтобы получить нетривиальный инвариант типа, мы ввели новое условие — стек не должен иметь повторяющиеся элементы.

package Stacks is

type Stack is private

with Type_Invariant => Is_Unduplicated (Stack);

function Is_Empty (S: Stack) return Boolean;

function Is_Full (S: Stack) return Boolean;

function Is_Unduplicated (S: Stack) return Boolean;

function Contains (S: Stack; X: Float) return Boolean;

--  Внимание! Из Contains(S,X) следует Is_Empty(S)=False

procedure Push (S: in out Stack; X: in Float)

with

Pre => not Contains(S,X) and not Is_Full(S),

Post => Contains(S,X);

procedure Pop (S: in out Stack; X: out Float)

with

Pre => not Is_Empty(S),

Post => not Contains(S,X) and not Is_Full (S);

procedure Clear (S: in out Stack)

with

Post => Is_Empty(S);

private

...

end Stacks;

Синтаксис спецификаций аспектов выглядит очевидным. Отсутствие пред-условия (как в Clear) эквивалентно пред-условию True.

Контракты (т. е. пред/пост-условия и инварианты) можно использовать по разному. В простейшем случае они уточняют намерения автора и выступают в роли формальной документации. Они также могут служить для генерации проверок соответствующих условий в момент исполнения. Директива Assertion_Policy управляет этим поведением. Она имеет форму

pragma Assertion_Policy(policy_identifier);

Когда policy_identifier равен Check, проверки генерируются, а если Ignore, то игнорируются. (Поведение по умолчанию, в отсутствии этой директивы, зависит от реализации компилятора.)

Третий способ использования контрактов способствует использованию формальных методов доказательства свойств программы, например, доказательство того, что код подпрограммы согласован с пред- и пост-условиями. Этот подход на примере языка SPARK мы обсудим в другой главе.

Стандарт Ada 2012 включает разнообразные конструкции, связанные с контрактным программированием, которые не попали в наш пример. Кванторные выражения (for all и for some) напоминают инструкции циклов. Функции-выражения позволяют поместить простейшую реализацию функций прямо в спецификацию пакета. Это выглядит логичным при задании пред/пост-условий, поскольку они являются частью интерфейса пакета. В Ada 2012 добавлены новые атрибуты: 'Old — позволяет в пост-условии сослаться на исходное значение формального параметра подпрограммы, а 'Result в пост-условии ссылается на результат, возвращаемый функцией. За более детальной информацией можно обратиться к стандарту языка или к разъяснениям стандарта (Rationale Ada 2012).

Следует отметить, что степень детализации условий контракта может значительно варьироваться. В нашем примере единственное требование к подпрограмме Push состоит в том, что элемент должен быть добавлен в стек. В то же время, семантика стека «последний вошел, первый вышел» более конкретна: элемент должен быть добавлен так, чтобы следующий вызов Pop его удалил. Аналогично, от Pop требуется, чтобы он вернул какой-то элемент. Если мы хотим быть более точными, необходимо указать, что этот элемент был добавлен последним. Подобные условия также можно написать, используя средства языка Ada 2012. Мы оставляем это читателю в качестве упражнения.

Footnotes

Безопасное объектно-ориентированное программирование

Появившись в первый раз в языке Simula в 1960-х, объектно-ориентированное программирование (ООП) распространилось затем в исследовательских и академических кругах с такими языками как Smalltalk в конце 1980-х и заняло существующее прочное положение с появлением C++ и Java в начале 1990-х. Выдающимся свойством ООП считается его гибкость. Но гибкость в чем-то похожа на свободу, которую мы обсуждали во введении — злоупотребляя ею, можно допустить появление опасных ошибок.

Ключевая идея ООП в том, что доминирующая роль достается объектам, в то время как процедуры (методы) управления объектом являются его свойствами. Старый же метод, называемый структурным программированием, заключается в декомпозиции подпрограмм, когда организация программы определяется структурой подпрограмм, при этом объекты остаются пассивными сущностями.

Оба подхода имеют право на жизнь и своих сторонников. Существуют случаи, когда строгий ООП подход использовать неуместно.

Язык Ада достигает поразительного баланса. Мы с уверенностью можем назвать его методологически нейтральным в сравнении с языком Java, например, который является «чистым» ООП. В самом деле, идеи ООП проникли в язык Ада еще при его создании, в 1980-х, проявившись в концепции пакетов и приватных типов, как механизма скрытия деталей реализации и задач, как механизма абстракции активных сущностей. Стандарт Ада 95 включил главные свойства ООП, такие как наследование, полиморфизм, динамическое связывание и понятие «класса» как набора типов, связанных отношением наследования.

ООП вместо структурного программирования

Мы рассмотрим два примера для иллюстрации различных моментов. Мы выбрали их, исходя из легкости их понимания, что избавит нас от необходимости объяснять прикладную область. Примеры касаются геометрических объектов (коих существует великое множество) и людей (которых только две категории, мужчины и женщины).

Сначала рассмотрим геометрические объекты. Для простоты остановимся на объектах на плоскости. У каждого объекта есть позиция. Мы можем определить базовый объект со свойствами, общими для всех видов объектов:

type Object is tagged record

X_Coord : Float;

Y_Coord : Float;

end record;

Здесь ключевое слово tagged (тегированный, то есть каждому типу соответствует уникальный тег) отличает этот тип от обычных записей (таких как Date из главы 3) и означает, что тип можно в будущем расширить. Более того, объекты такого типа хранят в себе специальное поле-тег, и этот тег определяет тип объекта во время исполнения. Объявив типы для специфических геометрических объектов, таких как окружность, треугольник, квадрат и прочие, мы получим различные значения тегов для каждого из типов. Компоненты X_Coord, Y_Coord задают центр объекта.

Мы можем объявить различные свойства объекта, такие как площадь и момент инерции. Каждый объект имеет эти свойства, но они зависят от формы объекта. Такие свойства можно определить при помощи функций и объявить их в том же пакете, что и тип. Таким образом, мы начнем с пакета:

package Geometry is

type Object is abstract tagged record

X_Coord, Y_Coord : Float;

end record;

function Area(Obj: Object) return Float is abstract;

function Moment(Obj: Object) return Float is abstract;

end Geometry;

Здесь мы объявили тип и его операции, как абстрактные. На самом деле нам не нужны объекты типа Object. Объявив тип абстрактным, мы предотвратим создания таких объектов по ошибке. Нам нужны реальные объекты, такие как окружности, у которых есть свойства, такие как площадь. Если нам потребуется объект точка, мы объявим отдельный тип Point для этого. Объявив функции Area и Moment абстрактными, мы гарантируем, что каждый конкретный тип, такой как окружность, предоставит свой код для вычисления этих свойств.

Теперь мы готовы определить тип окружность. Лучше всего сделать это в дочернем пакете:

package Geometry.Circles is

type Circle is new Object with record

Radius : Float;

end record;

function Area(C: Circle) return Float;

function Moment(C: Circle) return Float;

end Geometry.Circles;

with Ada.Numerics; use Ada.Numerics;  -- для доступа к π

package body Geometry.Circles is

function Area(C: Circle) return Float is

begin

return π * C.Radius ** 2;

end Area;

function Moment(C: Circle) return Float is

begin

return 0.5 * C.Area * C.Radius ** 2;

end Moment;

end Geometry.Circles;

В этом примере мы порождаем тип Circle от Object. Написав new Object, мы неявно наследуем все видимые операции типа Object пакета Geometry, если мы не переопределим их. Поскольку наши операции абстрактны, а сам тип Circle — нет, мы обязаны переопределить их явно. Определение типа расширяет тип Object новым компонентом Radius, добавляя его к определенным в Object компонентам (X_Coord и Y_Coord).

Заметим, что код вычисления площади и момента располагается в теле пакета. Как было объяснено в главе «Безопасная архитектура», это значит, что код можно изменить и перекомпилировать без необходимости перекомпиляции описания самого типа и всех модулей, использующих его.

Затем мы могли бы объявить тип для квадрата Square (с дополнительным компонентом длинны стороны квадрата), треугольника Triangle (три компоненты соответствующие его сторонам) и так далее. При этом код для Object и Circle не нарушается.

Множество всевозможных типов из иерархии наследования от Object обозначаются как Object'Class и называются в терминологии Ады классом. Язык тщательно различает отдельные типы, такие как Circle от классов типа, таких как Object'Class. Это различие помогает избежать путаницы, которая может возникнуть в других языках. Если мы, в свою очередь, унаследуем тип от Circle, то будем иметь возможность говорить о классе Circle'Class.

В теле функции Moment продемонстрировано использование точечной нотации. Мы можем воспользоваться одной из следующих форм записи:

- C.Area – точечная нотация

- Area (C) – функциональная нотация

Точечная нотация появилась в стандарте Ада 2005 и смещает акцент в сторону ООП, указывая на то, что объект C доминирует над функцией Area. Теперь объявим несколько объектов, например:

A_Circle: Circle := (1.0, 2.0, Radius => 4.5);

My_Square: Square := (0.0, 0.0, Side => 3.7);

The_Triangle: Triangle := (1.0, 0.5, A=>3.0, B=>4.0, C=>5.0);

Процедура для печати свойств объекта может выглядеть так:

procedure Print(Obj: Object'Class) is  -- Obj is polymorfic

begin

Put("Area is "); Put(Obj.Area);  -- dispatcing call of Area

...

end Print;

Print (A_Circle);

Print (My_Square);

Формальный параметр Obj — полиморфный, т. е. он может ссылаться на объекты различного типа (но только из иерархии растущей из Object) в различные моменты времени.

Процедура Print может принимать любой объект из класса Object'Class. Внутри процедуры вызов Area динамически диспетчеризируется, чтобы вызвать функцию Area, соответствующую конкретному типу параметра Obj. Это всегда безопасно, поскольку правила языка таковы, что любой объект в классе Object'Class будет иметь функцию Area. В тоже время сам тип Object объявлен абстрактным, следовательно нет способа создать объекты этого типа, поэтому не важно, что для этого типа нет функции Area, ведь ее вызов невозможен.

Аналогично мы могли бы объявить типы для людей. Например:

package People is

type Person is abstract record

Birthday: Date;

Height: Inches;

Weight: Pounds;

end record;

type Man is new Person with record

Bearded: Boolean;  -- Имеет бороду

end record;

type Woman is new Person with record

Births: Integer;  -- Кол-во рожденных детей

end record;

...  -- Различные операции

end People;

Поскольку все альтернативы заранее известны и новых типов не будет добавляться, мы могли бы использовать здесь запись с вариантами. Это будет в духе структурного программирования.

type Gender is (Male, Female);

type Person (Sex: Gender) is record

Birthday: Date;

Height: Inches;

Weight: Pounds;

case Sex is

when Male =>

Bearded: Boolean;

when Female =>

Births: Integer;

end case;

end record;

Затем мы объявим различные необходимые операции для типа Person. Каждая операция может иметь в теле инструкцию case чтобы принять во внимание пол человека.

Это может выглядеть довольно старомодно и не так элегантно, тем не менее этот подход имеет свои значительные преимущества.

Если нам необходимо добавить еще одну операцию в ООП подходе, весь набор типов нужно будет исправить, т. к. в каждом типе нужно добавить реализацию новой операции. Если нужно добавить новый тип, то это не затронет уже существующие типы.

В случае со структурным программированием все выглядит с точностью до наоборот.

Если нам нужно добавить еще один тип в структурном подходе, весь код нужно будет исправить, т. к. в каждой операции нужно реализовать случай для нового типа. Если нужно добавить новую операцию, то это не затронет уже существующие операции.

ООП подход считается более надежным ввиду отсутствия case инструкций, которые тяжело сопровождать. Хотя это действительно так, но иногда сопровождение ООП еще тяжелее, если приходится добавлять новые операции, что требует доработки каждого типа в иерархии.

Ада поддерживает оба подхода и они оба безопасны в Аде.

Индикатор overriding

Одна из уязвимостей ООП проявляется в момент переопределения унаследованных операций. При добавлении нового типа, нам необходимо добавить новые версии соответствующих операций. Если мы не добавляем свою операцию, то будет использоваться унаследованная от родителя.

Опасность в том, что, добавляя новую операцию, мы можем ошибиться в написании:

function Aera(C: Circle) return Float;

либо в типе аргумента или результата:

function Area(C: Circle) return Integer;

В любом случае, старая операция остается не переопределенной, а вместо этого создается совершенно новая операция. Когда надклассовая операция вызовет Area, будет выполнена унаследованная версия, а вновь добавленный код будет полностью проигнорирован. Подобные ошибки трудно диагностируются — компиляция проходит без ошибок, программа запускается и работает, но результат зачастую совершенно неожиданный.

(Хотя Ада предлагает механизм абстрактных операций, как например Area у Object, это лишь дополнительная мера предосторожности. И этого недостаточно, если мы порождаем тип от не абстрактного типа, либо мы не слишком осторожны, чтобы объявить функцию Area абстрактной.)

Чтобы предотвратить подобные ошибки, мы можем воспользоваться синтаксической конструкцией, появившейся в стандарте Ада 2005:

overriding function Area(C: Circle) return Float;

В этом случае, если будет допущена ошибка, компилятор обнаружит ее. С другой стороны, если мы действительно добавляем новую операцию, мы укажем это так:

not overriding function Aera(C: Circle) return Float;

То, что данный индикатор не является обязательным, главным образом обусловлено необходимостью сохранения совместимости с предыдущими версиями языка.

Возможно, синтаксис not overriding индикатора неоправдано тяжеловесен, учитывая необходимость частого его использования. Идеальным было бы требовать использования overriding для всех переопределенных операций и только для них. Другими словами, не использовать not overriding вообще. Это позволило бы находить оба типа ошибок:

- Ошибки в написании и другие ошибки, приводящие к отсутствию переопределения операций, фиксируются благодаря наличию overriding;

- Случайное переопределение операции (например, в случае появления новой операции в родительском типе) обнаруживается ввиду отсутствия overriding.

Требование совместимости делает такой подход невозможным в общем случае. Однако такого эффекта можно достичь, используя опции компилятора GNAT фирмы AdaCore:

- -gnatyO включает появление предупреждений о переопределении операций без использования overriding;

- -gnatwe заставляет компилятор трактовать все предупреждения как ошибки.

Другие языки, типа C++ и Java, предоставляют меньше содействия в этом аспекте, оставляя подобные ошибки не обнаруженными.

Запрет диспетчеризации вызова подпрограмм

В условиях, когда надежность критически важна, динамическое связывание часто запрещено. Надежность повышается, если мы можем доказать, что поток управления соответствует заданному шаблону, например, отсутствует недостижимые участки кода. Традиционно это означает, что нам приходится следовать методикам структурного программирования, вводя в явном виде такие инструкции, как if и case.

Хотя диспетчеризация вызовов подпрограмм является ключевым свойством ООП, другие возможности (например повторное использование кода благодаря наследованию) также являются привлекательными. Таким образом, возможность расширять типы, но без использования диспетчеризации, все еще имеет значительную ценность. Использование точечной нотации вызова также имеет свои преимущества.

Существует механизм, который позволяет отключать некоторые возможности языка Ада в текущей программе. Речь идет о директиве компилятору Restrictions. В данном случае мы напишем:

pragma Restrictions(No_Dispatch);

Это гарантирует (в момент компиляции), что в программе отсутствует конструкции типа X'Class, а значит и диспетчеризация вызова невозможна.

Заметим, что это ограничение соответствует требованиям языка SPARK, о котором мы упоминали во введении, часто используемого в критических областях. Язык SPARK позволяет использовать расширения типов, но запрещает надклассовые операции и типы.

Когда используется ограничение No_Dispatch, реализация языка получает возможность избежать накладных расходов, связанных с ООП. Нет необходимости создания в каждом типе «виртуальных таблиц» для диспетчеризации вызовов. (Такие таблицы содержат адреса всех операций данного типа). Также нет необходимости в специальном поле тега в каждом объекте.

Здесь существуют также менее очевидные преимущества. При полном ООП подходе некоторые предопределенные операции (например операция сравнения) также имеет возможность диспетчеризации, что приводит к дополнительным расходам. Итоговый результат применения ограничения минимизирует документирование неактивного кода (это код, который присутствует в программе и соответствует требованиям к ПО, но никогда не исполняется) в целях сертификации по стандартам DO-178B и DO-178C.

Интерфейсы и множественное наследование

Иногда множественное наследование расценивается как Святой Грааль в индустрии ПО и как критерий оценки языков программирования. Здесь мы не будем отвлекаться на историю развития этого вопроса. Вместо этого мы остановимся на основных проблемах, связанных с этим механизмом.

Допустим, у нас есть возможность унаследовать тип от двух произвольных родительских типов. Вспомним знаменитый роман «Флатландия» Эдвина Эбботта (вышедший в 1884г.). Это сатира на социальную иерархию, в которой люди - это плоские геометрические фигуры. Рабочий класс - это треугольники, средний класс - другие полигоны, аристократы - окружности. Удивительно, но женщины там - двуугольники, т. е. просто отрезки прямой линии.

Используя объявленные ранее типы Object и Person, мы могли бы попытаться определить обитателей Флатландии как тип, унаследованный от обоих типов:

type Flatlander is

new Geometry.Object and People.Person; -- illegal

Вопрос который теперь возникает: какие свойства унаследует новый тип? Мы ожидаем, что Flatlander унаследует компоненты X_Coord и Y_Coord от Object и Birthday от Person, хотя Heigh и Weight выглядит сомнительно для плоских персонажей. Конечно Area должен быть унаследован, потому, что Flatlander имеет площать, как и момент инерции.

Теперь должно быть ясно, какие проблемы могут возникнуть. Допустим, оба родительских типа имеют операцию с одним именем. Это весьма вероятно для широко распространенных имен типа Print, Make, Copy и т. д. Какую из них нужно наследовать? Что делать, если оба родителя имеют компоненты с одинаковыми именами? Подобные вопросы объязательно возникнут, если оба родителя имеют общий родительский тип.

Некоторые языки реализуют множественное наследование в такой форме, вводя сложные правила, чтобы урегулировать подобные вопросы. Примером могут служить C++ и Eiffel. Возможные решения включают переименование, явное указание имя родителя в неоднозначных случаях, либо выбор родительского типа согласно позиции в списке. Некоторые из предлагаемых решений имеют субъективный оттенок/характер, для кого-то они очевидны, хотя других приводят в замешательство. Правила C++ дают широкую свободу программисту наделать ошибок.

Трудности возникают в основном двух видов: наследование компонент и наследование реализаций операций от более чем одного родителя. Но фактически проблем с наследованием спецификации (другими словами интерфейса) операции не бывает. Этим воспользовались в языке Java и этот путь оказался довольно успешным. Он также реализован и в языке Ада.

Таким образом, в Аде, начиная со стандарта Ada 2005, мы можем наследовать от более чем одного типа:

type T is new A and B and C with record

... -- дополнительные компоненты

end record;

но только первый тип в списке (A) может иметь компоненты и реальные операции. Остальные типы должны быть так называемыми интерфейсами (термин позаимствован у Java умышленно), т. е. абстрактными типами без компонент, у которых все операции либо абстрактные, либо null-процедуры. (Первый тип может также быть интерфейсом.)

Мы можем описать Object, как интерфейс:

package Geometry is

type Object is interface;

procedure Move(   Obj: in out Object;

New_X, New_Y: Float) is abstract;

function X_Coord(Obj: Object) return Float is abstract;

function Y_Coord(Obj: Object) return Float is abstract;

function Area(Obj: Object) return Float is abstract;

function Moment(Obj: Object) return Float is abstract;

end Geometry;

Обратите внимание, что компоненты были удалены и заменены дополнительными операциями. Процедура Move позволяет передвигать объект, т. е. устанавливать новые координаты x и y. Функции X_Coord, Y_Coord возвращают текущую позицию.

Также следует заметить, что точечная нотация позволяет по прежнему обращаться к координатам, написав A_Circle.X_Coord и The_Triangle.Y_Coord, как если бы это были компоненты.

Теперь при определении конкретного типа мы должны предоставить реализацию всем этим операциям. Предположим:

package Geometry.Circles is

type Circle is new Object with private; -- partial view

procedure Move(C: in out Circle; New_X, New_Y: Float);

function X_Coord(C: Circle) return Float;

function Y_Coord(C: Circle) return Float;

function Area(C: Circle) return Float;

function Moment(C: Circle) return Float;

function Radius(C: Circle) return Float;

function Make_Circle(X, Y, R: Float) return Circle;

private

type Circle is new Object with record

X_Coord, Y_Coord: Float;

Radius : Float;

end record;

end Geometry.Circles;

package body Geometry.Circles is

procedure Move(C: in out Circle; New_X, New_Y: Float) is

begin

C.X_Coord := New_X;

C.Y_Coord := New_Y;

end Move;

function X_Coord(C: Circle) return Float is

begin

return C.X_Coord;

end X_Coord;

-- Аналогично Y_Coord, а Area и Moment — как ранее

end Geometry.Circles;

Мы определили тип Circle как приватный, чтобы спрятать все его компоненты. Тем не менее, поскольку приватный тип унаследован от Object, он наследует все свойства Object. Обратите внимание, что мы добавили функции для создания окружности и получения его радиуса.

В основе программирования с использованием интерфейсов лежит идея, что мы обязаны предоставить реализацию операций, требуемых интерфейсом. Здесь множественное наследование не касается наследования существующих свойств, скорее это наследование контрактов, которым необходимо следовать. Таким образом, Ада позволяет множественное наследование интерфейсов, но только единичное наследование для реализаций.

Возвращаясь к Флатландии, мы можем определить:

package Flatland is

type Flatlander is abstract new Person and Object

with private;

procedure Move(F: in out Flatlander; New_X,New_Y: Float);

function X_Coord(F: Flatlander) return Float;

function Y_Coord(F: Flatlander) return Float;

private

type Flatlander is abstract new Person and Object

with record

X_Coord,  Y_Coord : Float := 0.0;

... -- остальные необходимые компоненты

end record;

end Flatland;

Теперь тип Flatlander будет наследовать компоненту Birthday и прочие от типа Person и все реализации операций типа Person (мы не показываем их тут) и абстрактные операции типа Object. Удобно определить координаты, как компоненты типа Flatlander, чтобы легко реализовать такие операции, как Move, X_Coord, Y_Coord. Обратите внимание, что мы задали начальное значение этих компонент, как ноль, чтобы задать положение Flatlander по умолчанию.

Тело пакета будет следующим:

package body Flatland is

procedure Move(F: in out Flatlander; New_X,New_Y: Float)

is

begin

F.X_Coord := New_X;

F.Y_Coord := New_Y;

end Move;

function X_Coord(F: Flatlander) return Float is

begin

return F.X_Coord;

end X_Coord;

-- аналогично Y_Coord

end Flatland;

Сделав тип Flatlander абстрактным, мы избегаем необходимости немедленно предоставить реализацию всем операциям, например Area. Теперь мы можем объявить тип Square пригодным для Флатландии (когда роман вышел в печать, автор подписался псевдонимом A Square):

package Flatland.Squares is

type Square is new Flatlander with record

Size: Float;

end record;

function Area (S: Square) return Float;

function Moment (S: Square) return Float;

end Flatland.Square;

package body Flatland.Squares is

function Area (S: Square) return Float is

begin

return S.Size ** 2;

end Area;

function Moment (S: Square) return Float is

begin

return S.Area * S.Side ** 2 / 6.0;

end Moment;

end Flatland.Square;

Таким образом, все операции в итоге получили реализацию. В демонстрационных целях мы сделали дополнительный компонент Size видимым, хотя тут можно использовать и приватный тип. Теперь мы можем определить Др. Эбботта как:

A_Square : Square := (Flatland with Side => 3.0);

и он будет иметь все свойства квадрата и человека. Обратите внимание на агрегат, который получает значения по умолчанию для приватных компонент, а дополнительные компоненты инициализирует явно.

Существуют другие важные свойства интерфейсов, которых мы коснемся лишь вскользь. Интерфейс может иметь в качестве операции null-процедуру. Такая процедура ничего не делает при вызове. Если два родителя имеют одну и туже операцию, то null-процедура переопределяет абстрактную. Если два родителя имеют одну и ту же операцию (с совпадающими параметрами и результатом), они сливаются в одну операцию, для которой требуется реализация. Если параметры и/или результат отличаются, то необходимо реализовать обе операции, т. к. они перегружены. Таким образом, правила сформулированы так, чтобы минимизировать сюрпризы и максимизировать выигрыш от множественного наследования.

Взаимозаменяемость

Этот раздел касается специализированной темы, которая может быть интересна при углубленном изучении.

Наследование можно рассматривать с двух перспектив. С точки зрения возможностей языка, это способность породить тип от родительского и унаследовать состояние (компоненты) и операции, сохранив при этом возможность добавлять новые компоненты и операции и переопределять унаследованные операции. С точки зрения моделирования либо теории типов, наследование это отношение («это есть») между подклассом и супер-классом: если класс S - это подкласс T, то любой объект класса S также является объектом класса T. Это свойство — основа полиморфизма. В терминах языка Ада, для любого тегового типа T, переменная типа T'Class может ссылаться на объект типа T или любого типа, унаследованного (прямо или косвенно) от T. Это значит, что любая операция, возможная для T, будет работать (как унаследованная либо переопределенная) и для объекта любого подкласса T.

Более формальная формулировка этого требования известна, как принцип подстановки Барбары Лисков, который выражен в терминах теории типов:

Пусть q(x) свойство объектов x типа T истинно. Тогда q(y) истинно для объектов типа S, где S является подтипом T. (Здесь «подтип» означает «подкласс».)

Хорошей практикой является проектирование иерархии классов так, чтобы выполнялся данный принцип. Если он нарушается, то становится возможным вызвать неподходящую операцию, используя динамическое связывание, что приведет к ошибке времени исполнения. Это возможно в том случае, когда наследование используется там, где два класса должны быть связаны менее строгим отношением.

Хотя сам принцип Лисков может показаться очевидным, его связь с контрактным программированием таковой не является. Напомним, что в методе вы можете дополнить спецификацию подпрограмм пред- и/или пост-условиями. Встает вопрос, если вы переопределяете операцию, налагает ли принцип Лисков дополнительные ограничения на пред- и пост-условия для новой версии подпрограммы? Ответ - «да»: пред-условия не могут быть усилены (например, вы не можете сформулировать пред-условие, добавив условие к родительскому через and оператор). Аналогично, пост-условие не может быть ослаблено.

На первый взгляд это противоречит тому, чего вы можете ожидать. Подкласс обычно ограничивает множество значений своего супер-класса. Поэтому накладывать более сильные пред-условия операции подкласса может показаться имеющим смысл. Но при ближайшем рассмотрении оказывается, что это нарушает принцип Лисков. С точки зрения вызывающего, для выполнения операции X.Op(...) полиморфной переменной X, имеющей тип T, необходимо обеспечить выполнение предусловия операции Op типа T. У автора этого кода нет возможности знать все возможные подклассы T. Если случится так, что X ссылается на объект типа T1, у которого предусловие Op сильнее, чем у T, то вызов не сможет состояться, поскольку проверка пред-условия не пройдет. Аналогичные рассуждения докажут, что пост-условие в подклассе не может быть слабее. Вызывающий ожидает выполнение пост-условия после вызова операции, если подкласс этого не гарантирует, это приведет к ошибке.

Дополнение в области ООП и связанных технологий к стандарту DO-178C (DO-332) останавливается на этом вопросе. Оно не требует подчинения принципу Лисков, вместо этого предлагает проверять «локальную согласованность типов». «Согласованность типов» означает выполнение принципа Лисков: операции подкласса не могут иметь более сильные пред-условия и более слабые пост-условия. «Локальная» означает, что необходимо анализировать только реально встречающийся в программе контекст. Например, если существует операция, у которой пред-условие более сильное, но она никогда не вызывается при диспетчеризации вызова, то это не вредит.

Стандарт DO-332 предлагает три подхода доказательства локальной согласованности типов, один на основе формальных методов и два на основе тестирования:

- формально проверить взаимозаменяемость;

- удостовериться, что каждый тип проходит все тесты всех своих родителей, которых он может замещать;

- для каждой точки динамического связывания протестировать, что каждый метод может быть вызван (пессимистическое тестирование).

Первый подход предполагает непосредственную проверку принципа Лисков. Ада 2012 поддерживает явным образом пред- и пост-условия, что помогает провести автоматический формальный анализ, используя специальный инструментарий. Это рекомендуемый подход, если возможно использовать формальные методы, например при помощи инструмента SPARK Pro, поскольку он обеспечивает наивысший уровень доверия.

Второй подход применим при использовании модульного тестирования. В этом контексте, каждая операция класса обладает набором тестов для проверки требований. Переопределенная операция обычно имеет расширенные требования по сравнению с изначальной, поэтому будет иметь больше тестов. Каждый класс тестируется отдельно при помощи всех тестов, принадлежащих ему методов. Идея в том, чтобы проверить принцип взаимозаменяемости для некоторого тегового типа, выполнив все тесты всех его родительских типов, используя объект данного тегового типа. Gnattest, инструмент для модульного тестирования из состава GNAT Pro, предоставляет необходимую поддержку для автоматизации процесса тестирования, в том числе и принципа Лисков.

Третий подход может быть наименее сложным в случае, когда диспетчеризирумые вызовы редки и иерархия типов неглубокая. В составе GNAT Pro, есть инструмент GNATstack, способный найти все диспетчеризируемые вызовы с указанием всех возможных вызываемых подпрограмм.

Более подробную информацию по этой теме можно найти в документации «ООП для надежных систем на языке Ада» от AdaCore.

Footnotes

Безопасное создание объектов

Эта глава раскрывает некоторые аспекты управления объектами. Под объектами здесь мы понимаем как мелкие объекты в виде простых констант и переменных элементарного типа, например Integer, так и большие объекты из области ООП.

Язык Ада предоставляет развитые и гибкие инструменты в этой области. Эти инструменты, главным образом, не являются обязательными, но хороший программист использует их по-возможности, а хороший менеджер настаивает на их использовании по-возможности.

Переменные и константы

Как мы уже видели, мы можем определить переменные и константы, написав:

Top : Integer;  --  переменная

Max : constant Integer := 100;  --  константа

соответственно. Top - это переменная и мы можем присваивать ей новые значения, в то время как Max - это константа и ее значение не может быть изменено. Заметьте, что в определении константы задавать начальное значение необходимо. Переменным тоже можно задать начальное значение, но это не обязательно.

Преимущество констант в том, что их нельзя нечаянно изменить. Эта конструкция не только удобный «предохранитель». Она также помогает каждому, кто читает программу, сразу обозначая статус объекта. Важная деталь тут в том, что значение не обязательно должно быть статическим, т. е. известным в момент компиляции. В качестве примера приведем код вычисления процентных ставок:

procedure Nfv_2000 (X: Float) is

Factor: constant Float := 1.0 + X/100.0;

begin

return 1000.0 * Factor**2 + 500.0 * Factor - 2000.00;

end Nfv_2000;

Каждый вызов функции Nfv_2000 получает новое значение X и, следовательно, новое значение Factor. Но Factor не изменяется в течении одного вызова. Хотя этот пример тривиальный и легко видеть, что Factor не изменяется, необходимо выработать привычку использовать constant везде, где это возможно.

Параметры подпрограммы это еще один пример концепции переменных и констант.

Параметры бывают трех видов: in, in out и out. Если вид не указан в тексте, то, по умолчанию, используется in. В версиях языка вплоть до Ада 2005 включительно функции могли иметь параметры только вида in. Это ограничение имело методологический характер, чтобы склонить программиста не писать функции, имеющие побочные эффекты. На практике, однако, это ограничение на самом деле не работает. Создать функцию, имеющую побочные эффекты, легко, достаточно использовать ссылочный параметр или присваивание нелокальной переменной. Более того, в случае, когда побочный эффект необходим, программист был лишен возможности обозначить это явно, использовав подходящий вид параметра. Учитывая вышесказанное, стандарт Ада 2012, наконец, разрешил функциям иметь параметры всех трех видов.

Параметр вида in это константа, получающая значение аргумента вызова подпрограммы. Таким образом, X, из примера с Nfv_2000, имеет вид in и поэтому является константой, т. е. мы не можем присвоить ей значение и у нас есть гарантия, что ее значение не меняется. Соответствующий аргумент может быть любым выражением требуемого типа.

Параметры вида in out и out являются переменными. Аргумент вызова также должен быть переменной. Различие между этими видами касается начального значения. Параметр вида in out принимает начальное значение аргумента, в то время как параметр вида out не имеет начального значения (либо оно задается начальным значением, определенным самим типом параметра, например null для ссылочных типов).

Примеры использования всех трех видов параметров мы встречали в определении процедур Push и Pop в главе «Безопасная Архитектура»:

procedure Push (S: in out Stack; X: in Float);

procedure Pop (S: in out Stack; X: out Float);

Правила, касающиеся аргументов подпрограмм, гарантируют, что свойство «константности» не нарушается. Мы не можем передать константы, такие как Factor, при вызове Pop, поскольку соответствующий параметр имеет вид out. В противном случае это дало бы возможность Pop поменять значение Factor.

Различие между константами и переменными также затрагивает ссылочные типы и объекты. Так, если мы имеем:

type Int_Ptr is access all Integer;

K: aliased Integer;

KP: Int_Ptr := K'Access;

CKP: constant Int_Ptr := K'Access;

то значение KP можно изменить, а значение CKP — нет. Хотя мы не можем заставить CKP ссылаться на другой объект, мы можем поменять значение K:

CKP.all := 47;  -- установить значение K равным 47

С другой стороны:

type Const_Int_Ptr is access constant Integer;

J: aliased Integer;

JP: Const_Int_Ptr := J'Access;

CJP: constant Const_Int_Ptr := J'Access;

где мы используем constant в описании типа. Это значит, мы не можем поменять значение объекта J, используя ссылки JP и CJP. Переменная JP может ссылаться на различные объекты, в то время, как CJP ссылается только на J.

Вид только-для-чтения и для чтения-записи

Иногда необходимо разрешить клиенту читать переменную без возможности изменять ее. Другими словами, нужно предоставить вид только-для-чтения для данной переменной. Это можно сделать при помощи отложенной константы и ссылочного типа:

package P is

type Const_Int_Ptr is access constant Integer;

The_Ptr: constant Const_Int_Ptr;  -- отложенная константа

private

The_Variable: aliased Integer;

The_Ptr: constant Const_Int_Ptr := The_Variable'Access;

...

end P;

Клиент может читать значение The_Variable, используя The_Ptr, написав

K := The_Ptr.all;  -- косвенное чтение The_Variable

Но, поскольку ссылочный тип описан, как access constant значение объекта не может быть изменено

The_Ptr.all := K;  -- ошибка, так нельзя изменить The_Variable

В то же время, любая подпрограмма, объявленная в пакете P, имеет непосредственный доступ к The_Variable и может изменять ее значение. Этот способ особенно полезен в случает таблиц, когда таблица вычисляется динамически, но клиент не должен иметь возможности менять ее.

Используя возможности стандарта Ада 2005, можно избежать введения ссылочного типа

package P is

The_Ptr: constant access constant Integer;

private

The_Variable: aliased Integer;

The_Ptr: constant access constant Integer :=

The_Variable'Access;

...

end P;

Ключевое слово constant встречается дважды в объявлении The_Ptr. Первое означает, что The_Ptr это константа. Второе — что нельзя изменить объект, на который ссылается The_Ptr.

Функция-конструктор

В таких языках, как C++, Java и C# есть специальный синтаксис для функций, создающих новые объекты. Такие функции называются конструкторами, их имена совпадают с именем типа. Введение аналогичного механизма в Аде отклонили, чтобы не усложнять язык. Конструкторы в других языках имеют дополнительную семантику (например, определяют, как вызвать конструктор родительского типа, в какой момент вызывать конструктор относительно инициализации по умолчанию и т.д.). Ада предлагает несколько конструкций, которые можно использовать вместо конструкторов, например, использование дискриминантов для параметризации инициализации, использование контролируемых типов с предоставляемой пользователем процедурой Initialize (к этому мы вернемся позже), обыкновенные функции, возвращающие значение целевого типа, поэтому необходимости в дополнительных средствах нет.

Лимитируемые типы

Типы, которые мы встречали до сих пор (Integer, Float, Date, Circle и др.), имеют различные операции. Некоторые из них предопределены, к ним относятся сравнение на равенство. Другие, такие как Area у типа Circle, определены пользователем. Операция присваивания также существует у всех перечисленных выше типов.

В некоторых случаях иметь операцию присваивания нежелательно. Этому может быть две главные причины

- тип может представлять некоторый ресурс, например права доступа, копирование которого нарушает политику безопасности

- тип может быт реализован с использованием ссылок и копирование затронет только ссылку, а не все данные.

Мы можем предотвратить присваивание, объявив тип limited. Для иллюстрации второй причины рассмотрим стек, реализованный в виде односвязного списка:

package Linked_Stacks is

type Stack is limited private;

procedure Clear(S: out Stack);

procedure Push(S: in out Stack; X: in Float);

procedure Pop(S: in out Stack; X: out Float);

private

type Cell is record

Next: access Cell;

Value: Float;

end record;

type Stack is access all Cell;

end Linked_Stacks;

Тело пакета может быть следующим:

package body Linked_Stacks is

procedure Clear(S: out Stack) is

begin

S := null;

end Clear;

procedure Push(S: in out Stack; X: in Float) is

begin

S := new Cell'(S, X);

end Push;

procedure Pop(S: in out Stack; X: out Float) is

begin

X := S.Value;

S := Stack (S.Next);

end Pop;

end Linked_Stacks;

Объявление стека как limited private запрещает операцию присваивания.

This_One, That_One: Stack;

This_One := That_One;  -- неверно, тип Stack лимитированный

Если бы такое присваивание сработало, это привело бы к тому, что This_One указывал бы на тот же список, что и That_One. Вызов Pop с This_One просто сдвинет его по списку That_One вниз. Проблемы такого характера имеют общепринятое название — алиасинг, т. е. существование более чем одного способа сослаться на один и тот же объект. Зачастую это чревато плохими последствиями.

Объявление стека в данном примере работает успешно, благодаря тому, что он автоматически специализируется значением null, обозначающим пустой стек. Однако, бывают случаи, когда необходимо создать объект, инициализировав его конкретным значением (например, если мы объявляем константу). Мы не можем сделать это обычным способом:

type T is limited ...

...

X: constant T := Y;  --  ошибка, нельзя скопировать переменную

поскольку это повлечет копирование, что запрещено для лимитируемого типа.

Можно воспользоваться двумя конструкциями — агрегатами и функциями. Сначала рассмотрим агрегаты. Пусть наш тип представляет некий ключ, содержащий дату выпуска и некоторый внутренний код:

type Key is limited record

Issued: Date;

Code: Integer;

end record;

Поскольку тип лимитируемый, ключ нельзя скопировать (сейчас его содержимое видно, но мы это исправим позже). Но мы можем написать:

K: Key := (Today, 27);

так как, в этом случае, нет копирования целого ключа, вместо этого отдельные компоненты получают свои значения. Другими словами K строится по месту нахождения.

Более реалистично было бы объявить тип приватным. Тогда мы бы не имели возможности использовать агрегат, поскольку компоненты не были бы видимы. В этом случае мы бы использовали функцию, как конструктор:

package Key_Stuff is

type Key is limited private;

function Make_Key(...) return Key;

...

private

type Key is limited record

Issued: Date;

Code: Integer;

end record;

end Key_Stuff;

package body Key_Stuff is

function Make_Key(...) return Key is

begin

return New_Key: Key do

New_Key.Issued := Today;

New_Key.Code := ...;

end return;

end Make_Key;

...

end Key_Stuff;

Клиент теперь может написать

My_Key: Key := Make_Key (...);  -- тут нет копирования

где параметры Make_Key используются для вычисления ключа.

Давайте обратим внимание на функцию Make_Key. Она содержит расширенную инструкцию возврата (return), которая начинается с объявления возвращаемого объекта New_Key. Когда результирующий тип функции лимитируемый, возвращаемый объект, на самом деле, строится сразу по месту своего нахождения (в нашем случае в переменной My_Key). Это выполняется аналогично тому, как заполняются компоненты при использовании агрегата. Поэтому копирования не выполняется.

В итоге в Аде мы имеем механизм инициализации клиентских объектов без использования копирования. Использование лимитируемых типов дает создателю ресурсов, таких как ключи, мощный механизм контроля их использования.

Контролируемые типы

Еще более мощным механизмом управлением объектами являются контролируемые типы. С их помощью можно написать код, исполняемый когда:

1. объект создается; 1. объект прекращает существование; 1. объект копируется, если он не лимитируемого типа.

В основе этого механизма лежат типы Controlled и Limited_Controlled, объявленные в пакете Ada.Finalization:

package Ada.Finalization is

type Controlled is abstract tagged private;

procedure Initialize(Object: in out Controlled) is null;

procedure Adjust(Object: in out Controlled) is null;

procedure Finalize(Object: in out Controlled) is null;

type Limited_Controlled is abstract tagged private;

procedure Initialize(Object: in out Limited_Controlled)       is null;

procedure Finalize(Object: in out Limited_Controlled)

is null;

private

...

end Ada.Finalization;

Синтаксис is null введен в Ада 2005 и упрощает определение поведения по умолчанию.

Основная идея (для нелимитируемых типов) состоит в том, что пользователь наследует свой тип от Controlled и переопределяет процедуры Initialize, Adjust и Finalize. Эти процедуры вызываются, когда объект создается, копируется и уничтожается, соответственно. Отметим, что вызов этих подпрограмм вставляется автоматически компилятором и программисту не нужно явно их вызывать. Аналогично обстоит дело с лимитируемыми типами. Различие в том, что используется Limited_Controlled тип, у которого отсутствует подпрограмма Adjust, поскольку копирование запрещено. Эти подпрограммы используются, чтобы реализовать сложную инициализацию, осуществлять глубокое копирование связных структур данных, освобождение памяти по окончании жизни объекта и тому подобной деятельности, специфичной для данного типа.

В качестве примера, снова рассмотрим стек, реализованный в виде связного списка, но предоставим возможность копирования. Напишем:

package Linked_Stacks is

type Stack is limited private;

procedure Clear(S: out Stack);

procedure Push(S: in out Stack; X: in Float);

procedure Pop(S: in out Stack; X: out Float);

private

type Cell is record

Next: access Cell;

Value: Float;

end record;

type Stack is new Controlled with record

Header: access Cell;

end record;

overriding procedure Adjust(S: in out Stack);

end Linked_Stacks;

Тип Stack теперь приватный. Полное объявление типа - это теговый тип, порожденный от типа Controlled и имеющий компонент Header, аналогичный предыдущему объявлению стека. Это просто обертка. Клиент же не видит, что наш тип теговый и контролируемый. Чтобы присваивание работало корректно, мы переопределяем процедуру Adjust. Обратите внимание, что мы используем индикатор overriding, что заставляет компилятор проверить правильность параметров. Тело пакета может быть следующим:

package body Linked_Stacks is

procedure Clear(S: out Stack) is

begin

S := (Controlled with Header => null);

end Clear;

procedure Push(S: in out Stack; X: in Float) is

begin

S.Header := new Cell'(S.Header, X);

end Push;

procedure Pop(S: in out Stack; X: out Float) is

begin

X := S.Header.Value;

S.Header := S.Header.Next;

end Pop;

function Clone(L: access Cell) return access Cell is

begin

if L = null then

return null;

else

return new Cell'(Clone(L.Next), L.Value);

end if;

end Clone;

procedure Adjust (S: in out Stack) is

begin

S.Header := Clone (S.Header);

end Adjust;

end Linked_Stacks;

Теперь присваивание будет работать как надо. Допустим, мы напишем:

This_One, That_One: Stack;

...

This_One := That_One;  --  автоматический вызов Adjust

Сперва выполняется побитовое копирование That_One в This_One, затем для This_One выполняется вызов Adjust, где вызывается рекурсивная функция Clone, которая и выполняет фактическое копирование. Часто такой процесс называют глубоким копированием. В результате This_One и That_One содержат одинаковые элементы, но их внутренние структуры никак не пересекаются.

Интересным моментом, также, может быть то, как в процедуре Clear устанавливается параметр S. Эта конструкция называется расширенным агрегатом. Первая часть агрегата — имя родительского типа, а часть после слова with предоставляет значения дополнительным компонентам, если такие имеются. Процедуры Push и Pop — тривиальны.

Читатель может спросить, что произойдет с занимаемой памятью после вызова процедуры Pop или Clear. Мы обсудим это в следующей главе, касающейся вопросов управления памятью.

Следует отметить, что процедуры Initialize и Finalize не переопределены и наследуются пустые процедуры от типа Controlled. Поэтому ничего дополнительного не выполняется в момент объявления стека. Это нам подходит, потому что компонента Header получает значение null по умолчанию, что нам и требуется. Аналогично, никаких действий не происходит, когда стек уничтожается, например при выходе из процедуры. Тут снова встает вопрос об освобождении памяти, к которому мы вернемся в следующей главе.

Footnotes

Безопасное управление памятью

Компьютерная память, используемая программой, является критически важным ресурсом системы. Целостность его содержимого является необходимым условием здорового функционирования программы. Тут можно проследить аналогию с памятью человека. Когда память ненадежна, жизнь человека заметно ухудшается.

Есть две проблемы, которые связаны с вопросом управления памятью. Первая заключается в том, что информация может быть потеряна в случае, если она ошибочно перетирается другой информацией. Другая проблема в том, что память может быть утеряна после использования и, в конце концов, вся свободная память будет исчерпана, что приведет к невозможности сохранить нужную информацию. Эта проблема утечки памяти.

Утечка памяти является коварной проблемой, поскольку может не проявляться длительное время. Известны примеры из области управления химическим производством, когда казалось, что программа работала в течении нескольких лет. Ее перезапускали каждые три месяца по независимым причинам (перемещали кран, что приводило к остановке производства). Когда график перемещения крана изменился, программа должна была работать дольше, но в итоге сломалась после четырех месяцев непрерывной работы. Причина оказалась в утечке памяти, понемногу отгрызающей свободное пространство.

Переполнение буфера

Переполнение буфера - это общее название, используемое для обозначения нарушения информационной безопасности. Переполнение буфера может привести к искажению или чтению информации злоумышленником, либо случайно.

Эта проблема широко распространена в программах на C и C++ и зачастую связана с отсутствием проверок выхода за пределы массивов в этих языках. Мы встречались с подобной проблемой в главе «Безопасные типы данных» в примере с парой игральных костей.

Эта проблема не может возникнуть в Аде, поскольку в обычных условиях проверка индекса при обращении к массиву активирована. Эту проверку можно отключить, когда мы абсолютно уверены в поведении программы, но это может быть неблагоразумно, пока мы не доказали корректность программы формальным методом, например, используя инструментарий SPARK Examiner, который мы обсудим в главе 11.

Хотя, в подавляющем количестве случаев виновником переполнения буфера является отсутствие проверки индекса массива, другие свойства языка также могут его вызвать. Например, обозначение конца строки с помощью нулевого байта. Это приводит ко множеству мест в программе, где программист должен проверить этот маркер. Легко ошибиться, выписывая эти тесты так, чтобы они работали верно в любой ситуации. В результате это приводит к появлению узких мест, которые используются вирусами для проникновения в систему.

Другой распространенной причиной разрушения данных является использование некорректных значений указателей. Указатели в C трактуются как адреса и для них разрешены арифметические операции. Как следствие, легко может возникнуть ситуация, когда значение указателя вычислено неверно. Запись по этому указателю разрушит какие-то данные.

В главе «Безопасные указатели» мы видели, что строгая типизация указателей и правила контроля доступности в Аде защищают нас от подобных ошибок, гарантируя, что объявленный объект не исчезнет, пока на него ссылаются другие объекты.

Таким образом фундаментальные свойства языка Ада защищают от случайной потери данных, связанной с разрушением содержимого памяти. Остаток этой главы мы посвятим проблеме утечки памяти.

Динамическое распределение памяти

Обычно языки программирования предоставляют три способа распределения памяти:

- глобальные данные существуют в течении всего времени работы программы, поэтому могут иметь постоянное положение в памяти и обычно распределяются статически;

- данные ,сохраненные в стеке, распределяются и освобождаются синхронно с вызовом подпрограмм;

- данные, распределенные динамически, время жизни которых не связанно с временем работы подпрограмм.

Секция common в Fortran — исторический пример глобального статического распределения, но подобные механизмы есть и в других языках. В Аде мы можем объявить:

package Calandar_Data is

type Month is (Jan, Feb, Mar, ..., Nov, Dec);

Days_In_Month: array (Month) of Integer :=

(Jan => 31, Feb => 28, Mar => 31, Apr => 30,

May => 31, Jun => 30, Jul => 31, Aug => 31,

Sep => 30, Oct => 31, Nov => 30, Dec =>31);

end;

Память, выделяемая под Days_In_Month, будет, естественно, выделена в фиксированной глобальной области.

Стек - важный механизм распределения памяти во всех современных языках программирования. Отметим, что речь тут идет о механизме, связанном с реализацией распределения памяти, а не об объектах типа Stack из предыдущих глав. Стек используется для передачи параметров при вызове подпрограмм (в том числе передачи аргументов, хранения адреса возврата, сохранения промежуточных регистров, и т. д.), а также локальных переменных подпрограммы. В многозадачной программе, где несколько потоков управления исполняются параллельно, каждая задача имеет свой стек.

Вернемся к функции Nfv_2000 из примера вычисления процентных ставок:

procedure Nfv_2000 (X: Float) is

Factor: constant Float := 1.0 + X/100.0;

begin

return 1000.0 * Factor**2 + 500.0 * Factor - 2000.00;

end Nfv_2000;

Объект Factor обычно распределяется в стеке. Он создается при вызове функции и уничтожается при возврате. Все управление памятью происходит автоматически, благодаря механизму вызова/возврата подпрограмм. Отметим, что, хотя Factor является константой, он не является статическим объектом, потому что каждый вызов функции вычисляет для него свое значение. Так как две задачи могут вызвать эту функцию одновременно, Factor нельзя распределить статически. Аналогично, параметр X также распределяется в стеке.

Теперь рассмотрим более сложный случай, когда подпрограмма объявляет локальный массив, чей размер неизвестен до момента исполнения. Например это может быть функция, возвращающая массив в обратном порядке:

function Rev (A: Vector) return Vector is

Result: Vector(A'Range);

begin

for K in A'Range loop

Result (K) := A(A'First+A'Last-K);

end loop;

return Result;

end Rev;

где Vector объявлен, как неограниченный массив:

type Vector is array (Natural range <>) of Float;

Как объясняется в разделе «Массивы и ограничения» главы «Безопасные типы данных», эта запись означает, что Vector - это массив, но границы у разных объектов этого типа могут быть разные. Когда мы объявляем объект этого типа, мы должны предоставить границы. У нас может быть:

L: Integer := ...;    -- L может не быть статическим значением

My_Vector, Your_Vector: Vector (1 .. L);

...

Your_Vector := Rev (My_Vector);

В большинстве языков программирования нам бы пришлось распределить память для такого объекта динамически, поскольку размер объекта не известен заранее. На самом деле, это не является необходимым, поскольку стек может расти динамически, а память для локальных объектов всегда распределяется по принципу последний-зашел-первый-вышел. Такого рода требования возникают для простоты реализации языка. Приложив некоторые усилия во время дизайна и реализации языка, можно распределять такого рода объекты в стеке, сохранив при этом эффективность механизма вызова подпрограмм.

Хотя такое поведение не требуется согласно стандарту, все промышленные компиляторы всегда используют стек для хранения локальных данных. Эффективной техникой в этом случае является использование двух стеков, один для хранения адресов возврата и локальных данных фиксированного размера, а другой для данных переменного размера. Это позволит обрабатывать данные фиксированного размера столь же эффективно, но сохранит требуемую гибкость в распределении памяти. Кроме того, в Аде часто применяется контроль за исчерпанием стека. В этом случает при попытке превысить отведенный размер стека будет возбуждаться исключение Storage_Error.

Данный пример красиво реализуется в Аде. Реализация на C контрастирует своей сложностью ввиду того, что в C нет соответствующей абстракции массивов. Мы можем передать массив, как аргумент, но только при помощи указателя на массив. Кроме того, в C нельзя вернуть массив, как объект. Хотя мы можем определить функцию, которая переставляет элементы прямо в массиве, и требовать от пользователя создавать копию перед ее вызовом. При этом нужно быть осторожным, чтобы не испортить данные при перестановке. Проще будет разрешить пользователю передавать как указатель на аргумент, так и указатель на результат. Следующее затруднение состоит в том, что в C мы не можем определить размер массива. Нам придется размер передавать явно. Мы получаем еще один шанс допустить ошибку, передав значение, не соответствующее длине массива. В итоге мы получим

void rev(float* a, float* result, int length)

{

for (k=0;k<length;k++)

result[k]=a[length-k-1];

}

...

float my_vector[100], your_vector[100];

...

rev(my_vector, your_vector, 100);

Хотя эта глава посвящена управлению памятью, наверное стоит остановиться, чтобы перечислить риски и затруднения в этом коде на C.

- Массивы в C всегда индексируются, начиная с 0. Если прикладная область использует другую нумерацию, например с 1, может возникнуть путаница. В Аде нижняя граница присутствует всегда в явном виде.

- Длина массива должна передаваться отдельно, что создает риск получить неверную длину, либо перепутать длину и верхнюю границу массива. В Аде атрибуты массива неотделимы от массива.

- Адрес результата необходимо передавать отдельно. Появляется возможность перепутать два массива.

- Цикл для итерации по массиву нужно записывать явно, в то время как в Аде можно воспользоваться атрибутом 'Range.

Но мы отклонились от темы. Ключевой момент в том, что, если бы мы объявили локальный массив в C++, чей размер не задан статически:

void f(int n, ...)

{

float a[]=new float[n];

то память под такой массив распределялась бы динамически, а не в стеке. В C пришлось бы использовать функцию malloc.

Основная опасность при динамическом распределении памяти в том, что она может быть потеряна после использования. Поскольку в языке Ада возможно создавать объекты произвольного размера в стеке, необходимость динамического распределения памяти значительно снижается, что повышает производительность и уменьшает риск утечки памяти.

Пулы памяти

Давайте рассмотрим динамическое распределение памяти. Для этого в Аде используются пулы памяти. Если мы создаем объект динамически, как например в процедуре Push из главы «Безопасное создание объектов»:

procedure Push(S: in out Stack; X: in Float) is

begin

S := new Cell'(S, X);

end Push;

то память под новый Cell распределяется из пула памяти. Всегда существует стандартный пул памяти, но мы можем объявить и управлять своими собственными пулами памяти.

Первым языком программирования, избавившим программиста от необходимости управлением памятью, был LISP, благодаря использованию механизма сборки мусора. Этот механизм используется и в других языках, в том числе в Java и Python. Наличие сборщика мусора значительно упрощает программирование, но имеет свои проблемы. Например, сборщик мусора может приостанавливать исполнение программы непредсказуемым образом, что может привести к проблемам в системах реального времени. Программируя системы реального времени, необходимо тщательно контролировать распределение памяти, а также гарантировать время отклика программы, что может быть затруднительно при использовании сборщика мусора. Одной из причин, по которой в первый стандарт языка Ада 83 не включали средства ООП, было то, что автор языка, Жан Ишбиа, занимавшийся в свое время реализацией ООП языка Simula, был уверен в том, что ООП необходимо иметь сборщик мусора, а это неприемлемо для систем реального времени. Как впоследствии было продемонстрировано в C++ и Ада 95, язык может поддерживать ООП без сборщика мусора, если он предоставляет программисту развитые механизмы управления памятью.

Ада позволяет программисту выбрать один из следующих механизмов управления памятью:

- ручной режим. В этом случае программист освобождает память каждого объекта индивидуально.

- пул памяти. Объекты можно удалять, как каждый отдельно, так и весь пул целиком.

- сборщик мусора. Этот режим может быть реализован не во всех системах.

Чтобы удалить память, занимаемую некоторым объектом, нужно настроить предопределенную процедуру Unchecked_Deallocation. Для этого нужно предоставить именованный ссылочный тип. Вспомним тип Cell:

type Cell;

type Cell_Ptr is access all Cell;

type Cell is record

Next: Cell_Ptr;

Value: Float;

end record;

Обратите внимание, как здесь использовано неполное объявление типа, чтобы разорвать циклическую зависимость между типами. Теперь напишем:

procedure Free is new Unchecked_Deallocation (Cell, Cell_Ptr);

Чтобы удалить память, занимаемую объектом Cell, нужно вызвать процедуру Free и передать ей ссылку на удаляемый объект. Например, процедура Pop должна выглядеть так:

procedure Pop (S: in out Stack; X: out Float) is

Old_S : Stack := S;

begin

X := X.Value;

S := S.Next;

Free (Old_S);

end Pop;

Здесь мы используем Stack из примера с limited private, а не контролируемый тип.

Может показаться, что мы рискуем появлением висящих ссылок, поскольку могут быть другие ссылки, указывающие на удаленный объект. Но, в этом примере, с точки зрения пользователя, тип Stack лимитированный, следовательно ,пользователь не может сделать копию. Кроме того, пользователь не видит типов Cell и Cell_Ptr, поэтому не сможет вызвать Free. Это нам гарантирует корректность Pop. И, наконец, при настройке Unchecked_Deallocation используется тип Cell_Ptr, что позволяет проверить тип аргумента при вызове Free.

Нам необходимо изменить и процедуру Clear. Простейший вариант такой:

procedure Clear (S: in out Stack) is

Junk: Float;

begin

while S /= null loop

Pop (S, Junk);

end loop;

end Clear;

Хотя эта техника позволяет гарантировать, что память очищается при вызове Pop и Clear, существует риск, что пользователь объявит стек и выйдет из его области видимости пока стек не пуст. Например

procedure Do_Something is

A_Stack: Stack;

begin

... -- Используем стек

... -- Пуст ли стек при выходе?

end Do_Something;

Если стек не был пуст при выходе, то память будет потеряна. Мы не можем обременять пользователя заботой о таких деталях, поэтому мы должны сделать тип контролируемым, как было продемонстрировано в конце главы «Безопасное создание объектов». Мы переопределим процедуру Finalize так:

overriding procedure Finalize (S: in out Stack) is

begin

Clear (S);

end Finalize;

Использовав индикатор overriding, мы заставляем компилятор проверить, что мы не ошиблись в написании Finalize или в формальных параметрах.

В Аде также есть возможность объявить свои пулы памяти. Это просто, но потребует слишком много места для описания всех подробностей здесь. Основная идея в том, что есть тип Root_Storage_Pool (это лимитированный контролируемый тип) и мы объявляем свой тип, наследуя от него

type My_Pool_Type (Size: Storage_Count) is

new Root_Storage_Pool with private;

overriding procedure Allocate(...);

overriding procedure Deallocate(...);

-- также переопределим Initialize и Finalize

Процедура Allocate автоматически вызывается, когда создается новый объект при помощи new, а Deallocate — при вызове настройки Unchecked_Deallocation, такой как Free. Так мы реализуем необходимые действия по управлению памятью. Поскольку тип контролируемый, процедуры Initialize и Finalize автоматически вызываются при объявлении пула и его уничтожении.

Чтобы создать пул мы объявляем объект этого типа, как обычно. Наконец, необходимо привязать конкретный ссылочный тип к объекту-пулу.

Cell_Ptr_Pool: My_Pool_Type (1000); -- Размер пула — 1000

for Cell_Ptr'Storage_Pool use Cell_Ptr_Pool;

Важное преимущество пулов в том, что с их помощью можно уменьшить риск фрагментации памяти, если распределять объекты одного размера в одном пуле. Кроме того, мы можем написать свои алгоритмы распределения памяти или даже уплотнения, если захотим. Существует также возможность определить ссылочный тип локально, тогда и пул памяти можно определить локально и он будет автоматически удален по завершении подпрограммы, что исключит утечку памяти.

Пулы памяти были усовершенствованы в стандарте Ада 2012, где появились вложенные пулы. Мы не будем останавливаться здесь на этом, отметим лишь, что вложенные пулы — это части пула, уничтожаемые по отдельности.

Наконец, в качестве предохранителя от злоупотребления Unchecked_Deallocation, можно использовать тот факт, что Unchecked_Deallocation - это отдельный модуль компиляции. Следовательно, везде, где он используется, в начале текста будет:

with Unchecked_Deallocation;

Этот спецификатор контекста легко заметить при контроле качества программы.

Ограничения

Как мы уже знаем, есть общий механизм, гарантирующий отсутствие использования некоторых свойств языка, и это директива компилятору Restrictions. Если мы напишем:

pragma Restrictions(No_Dependence => Unchecked_Deallocation);

мы убедимся, что программа вообще не использует Unchecked_Deallocation — компилятор проверит это.

Существует около пятидесяти таких ограничений, которые контролируют различные аспекты программы. Многие из них узкоспециализированные и относятся к многозадачным программам. Другие касаются распределения памяти, например:

pragma Restrictions(No_Allocators);

pragma Restrictions(No_Implicit_Heap_Allocations);

Первый полностью запрещает использование конструкции new, как например new Cell'(...), а значит запрещает и динамическое распределение памяти вообще. Иногда, некоторые реализации используют динамическое распределение для хранения временных объектов. Это редкие случаи и второй вариант запрещает их появление.

Footnotes

Безопасный запуск

Мы можем тщательно написать программу, чтобы она правильно работала, но всё окажется бесполезно, если она не сможет корректно запуститься.

Машина, которая не заводится, никуда не годится, даже если она ездит как Rolls-Royce.

В случае с компьютерной программой, на старте необходимо убедиться, что все данные инициализированы правильно, зачастую это означает, что необходимо гарантировать, что операции инициализации выполняются в правильном порядке.

Предвыполнение

Типичная программа состоит из некоторого количества библиотечных пакетов P, Q, R и т. д. плюс главная подпрограмма M. При запуске программы пакеты предвыполняются, а затем вызывается главная подпрограмма. Предвыполнение пакета заключается в создании различных сущностей, объявленных в пакете на верхнем уровне. Но это не касается сущностей внутри подпрограмм, поскольку они создаются лишь в момент вызова этих подпрограмм.

Вернемся к примеру со стеком из главы «Безопасная Архитектура». Вкратце он выглядит так:

package Stack is

procedure Clear;

procedure Push(X: Float);

function Pop return Float;

end Stack;

package body Stack is

Max: constant := 100;

Top: Integer range 0 .. Max := 0;

A: array (1 .. Max) of Float;

... -- подпрограммы Clear, Push и Pop

end Stack;

Предвыполнение спецификации пакета не делает ничего, потому что не содержит объявлений объектов. Предвыполнение тела теоретически приводит к выделению памяти для целого Top и массива A. В данном случае, размер массива известен заранее, поскольку определяется константой Max, имеющей статическое значение. Следовательно, память под массив можно распределить заранее, до загрузки программы.

Но константа Max не обязательно должна иметь статическое значение. Она может принимать значение, например, вычисленное функцией:

Max: constant := Some_Function;

Top: Integer range 0 .. Max := 0;

A: array (1 .. Max) of Float;

И тогда размер массива должен быть рассчитан при предвыполнении тела пакета. Если, по беспечности, мы объявим Max как переменную и забудем присвоить ей начальное значение:

Max: Integer;

Top: Integer range 0 .. Max := 0;

A: array (1 .. Max) of Float;

размер массива будет зависеть от случайного значения, которое примет Max. Если значение Max будет отрицательным, это приведет к возбуждению исключения Constraint_Error, а если Max будет слишком большим то будет исключение Storage_Error. (Отметим, что большинство компиляторов выдаст предупреждение, поскольку анализ потока данных обнаруживает ссылку на неинициализированную переменную.)

Следует также отметить, что мы инициализируем переменную Top нулем, чтобы пользователю не пришлось вызывать Clear перед первым вызовом Push или Pop.

Также мы можем добавить в тело пакета код для явной инициализации, например так:

package body Stack is

Max: constant := 100;

Top: Integer range 0 .. Max := 0;

A: array (1 .. Max) of Float;

... -- подпрограммы Clear, Push и Pop

begin   -- далее явная инициализация

Top := 0;

end Stack;

Явная инициализация может содержать любые инструкции. Она исполняется во время предвыполнения тела пакета и до момента, когда любая из подпрограмм пакета вызывается извне.

Может показаться, что всегда предоставлять значения по умолчанию для все переменных — это хорошая идея. В нашем примере значение «0» - весьма подходящее и соответствует состоянию стека после исполнения Clear. Но в некоторых случаях нет очевидного подходящего значения для инициализации. В этих случаях, использовать произвольное значение не разумно, поскольку это может затруднить обнаружение реальных ошибок. Мы еще вернемся к этому вопросу при обсуждении языка SPARK в заключительной главе.

В случае числовых значений, отсутствие значения по умолчанию не обязательно приведет к катастрофе. Но в случае ссылочного типа или других неявных представлений адреса в памяти, катастрофа более реальна. В языке Ада все ссылочные объекты будут иметь значение null по умолчанию, либо будут явно инициализированы.

Потенциальные ошибки в процессе инициализации тесно связаны с попыткой доступа до окончания предвыполнения. Рассмотрим код:

package P is

function F return Integer;

X: Integer := F;      -- возбудит Program_Error

end;

где тело F конечно находится в теле пакета P. Невозможно вызвать F, чтобы получить начальное значение X до того, как тело F будет предвыполнено, поскольку тело F может ссылаться на переменную X или любую другую переменную, объявленную после X, ведь они все еще не инициализированы. Поэтому в Аде это приведет к возбуждению исключения Program_Error. В языке C подобные ошибки приведут к непредсказуемому результату.

Директивы компилятору, связанные с предвыполнением

Внутри одного модуля компиляции предвыполнение происходит в порядке объявления сущностей.

В случае программы, состоящей из нескольких модулей, каждый модуль предвыполняется после всех других, от которых он зависит. Так, тело предвыполняется после соответствующей спецификации, спецификация дочернего модуля — после спецификации родителя, все модули, указанные в спецификации контекста (без слова limited), предвыполняются до этого модуля.

Однако эти правила не полностью определяют порядок и их может быть недостаточно для гарантирования корректного поведения программы. Мы можем дополнить наш пример следующим образом:

package P is

function F return Integer;

end P;

package body P is

N: Integer := какое-то_значение;

function F return Integer is

begin

return N;

end F;

end P;

with P;

package Q is

X: Integer := P.F;

end Q;

Здесь важно, чтобы тело пакета P предвыполнилось до спецификации Q, иначе получить начальное значение X будет невозможно. Предвыполнение тела P гарантирует корректную инициализацию N. Но вычисление его начального значения может потребовать вызова функций из других пакетов, а эти функции могут ссылаться на данные инициализированные в теле пакетов, содержащих эти функции. Поэтому необходимо убедиться, что не только тело P предвыполняется до спецификации Q, но и тела всех пакетов, от которых зависит P, также предвыполнены. Описанные выше правила не гарантируют этого поведения, как следствие на старте может быть возбуждено исключение Program_Error.

Мы можем потребовать желаемый порядок предвыполнения, вставив специальную директиву компилятору:

with P;

pragma Elaborate_All (P);

package Q is

X: Integer := P.F;

end Q;

Отметим, что All в наименовании инструкции подчеркивает ее транзитивный характер. Как результат, предвыполнение пакета P (и всех его зависимостей) произойдет до предвыполнения кода Q.

Также существует инструкция Elaborate_Body, которую можно указать в спецификации, что приведет к тому, что тело предвыполнится сразу после спецификации. Во многих случаях этой инструкции достаточно, чтобы избежать проблем, связанных с порядком предвыполнения.

Здесь читатель может поинтересоваться, возможно ли решить проблему порядка предвыполнения, введя дополнительные простые правила в язык. Например, как если бы инcтрукция Elaborate_Body присутствовала всегда. К сожалению, это не сработает, поскольку полностью запретит взаимно рекурсивные пакеты (т. е. когда тело пакета P1 имеет спецификатор with P2; а P2 соответственно with P1).

Проблема нахождения правильного порядка предвыполнения может быть весьма сложной, особенно в больших системах. Иногда подобных проблем проще избежать, чем решать. Один из методов состоит в том, чтобы полностью отказаться от кода инициализации в телах пакетов, предоставив вместо этого главной подпрограмме явно вызывать процедуры для инициализации структур данных.

Динамическая загрузка

Вопрос динамической загрузки связан с вопросом запуска программы. Некоторые языки спроектированы так, чтобы создавать цельную согласованную программу, полностью собранную и загруженную к моменту исполнения. Среди них Ada, C и Pascal. Операционная система может выгружать из памяти и загружать обратно старницы с памятью программы, но это лишь детали реализации.

Другие языки созданы более динамическими. Они позволяют скомпилировать, загрузить и исполнить новый код прямо в процессе выполнения программы. COBOL, Java и C# среди них.

Для исполнения нового кода, в таких языках, как C, иногда используется механизм динамически загружаемых библиотек (DLL). Однако это не безопасно, поскольку при вызове подпрограмм отсутствует контроль параметров.

Подход, который можно предложить в Аде, использует механизм теговых типов для динамической загрузки. Смысл в том, что существующий код использует надклассовый тип (такой как Geometry.Object'Class) для вызова операций (таких как Area) любых конкретных новых типов (например пятиугольник, шестиугольник и пр.), и при этом создание новых типов не требует перекомпиляции существующего кода. Этого мы кратко касались в главе «Безопасное ООП». Этот механизм полностью безопасен с точки зрения строгой типизации.

Прекрасный пример, как с помощью этого подхода можно реализовать динамическую загрузку, можно найти в [7].

Footnotes

Безопасная коммуникация

Программа, которая не взаимодействует с внешним миром каким-либо образом, бесполезна, хотя и очень безопасна. Можно сказать, что она находится в своего рода одиночном заключении. Преступник в одиночном заключении — безопасен, в том смысле, что он не может навредить другим людям, но в то же время он бесполезен для общества.

Поэтому, чтобы быть полезной, программа должна взаимодействовать. Даже если программа написана правильно и в ней нет внутренних изъянов, это не имеет особого значения, если ее взаимодействие с внешним миром само не является безопасным. Таким образом, безопасность коммуникации очень важна, поскольку именно через нее программа проявляет свои полезные свойства.

Тут, наверное, стоит обратиться к введению, где мы обсуждали понятия безопасности и надежности программы, определив их, как возможность программы причинить вред ее окружению и, наоборот, получить ущерб от окружения. Так вот, коммуникация программы является основой как для ее надежности, так и для безопасности.

Представление данных

Важным аспектом взаимодействия является отображение абстрактного программного обеспечения на конкретное исполняющее устройство. Большинство языков перекладывают этот вопрос на плечи реализации. Но Ада предоставляет развитые механизмы контроля над многими аспектами представления данных.

Например, данные некоторой записи должны располагается в памяти специфическим образом, чтобы соответствовать требуемой структуре файла. Допустим, речь идет о структуре Key из главы «Безопасное создание объектов»:

type Key is limited record

Issued: Date;

Code: Integer;

end record;

где тип Date, в свою очередь, имеет следующий вид:

type Date is record

Day: Integer range 1 .. 31;

Month: Integer range 1..12;

Year : Integer;

end record;

Предположим, что наша целевая машина использует 32-х битные слова из четырех байт. Принимая во внимания ограничения диапазона, день и месяц свободно помещаются в один байт каждый и для года остается 16 бит (мы игнорируем «проблему 32768 года»). Вся запись красиво ложится в одно слово. Выразим это следующим образом:

for Date use record

Day at 0 range 0 .. 7;

Month at 1 range 0 .. 7;

Year at 2 range 0 .. 15;

end record;

В случае с типом Key требуемая структура - это два слова и реализация почти наверняка выберет это представление по умолчанию. Но мы можем гарантировать это, написав:

for Key use record

Issued at 0 range 0 .. 31;

Code at 4 range 0 .. 31;

end record;

В качестве следующего примера рассмотрим тип Signal из главы «Безопасные типы данных»:

type Signal is (Danger, Caution, Clear);

Пока мы не укажем другого, компилятор будет использовать 0 для представления Danger, 1 для Caution и 2 для Clear. Но в реальной системе может потребоваться кодировать Danger как 1, Caution как 2 и Clear как 4. Мы можем потребовать использовать такую кодировку, написав спецификатор представления перечислимого типа:

for Signal use (Danger => 1, Caution => 2, Clear => 4);

Заметьте, что ключевое слово for здесь не имеет отношения к инструкции цикла for. Такой синтаксис был выбран в целях облегчения чтения программы.

Далее, допустим, мы хотим гарантировать, чтобы любой объект типа Signal занимал один байт. Это особенно актуально для компонент массивов и записей. Это может быть достигнуто с помощью следующей записи:

for Signal'Size use 8;

Для Ады 2012 возможна альтернативная запись в виде спецификации аспекта прямо в определении типа:

type Signal is (Danger, Caution, Clear)

with Size => 8;

Развивая дальше этот пример, допустим, мы хотим чтобы переменная The_Signal этого типа находилась по адресу 0ACE. Мы можем добиться этого:

The_Signal: Signal;

for Signal'Address

use System.Storage_Elements.To_Address (16#0ACE#);

Значение атрибута 'Address должно быть типа Address, который обычно является приватным. Для преобразования целочисленного значения к этому типу здесь вызывается функция To_Address из пакета System.Storage_Elements.

Эквивалентный способ с использованием аспекта в Ада 2012 выглядит так:

The_Signal: Signal

with Address => System.Storage_Elements.To_Address (16#0ACE#);

Корректность данных

При получении данных из внешнего мира необходимо убедиться в их корректности. В большинстве случаев мы легко можем запрограммировать нужные проверки, но бывают и исключения.

Возьмем для примера опять тип Signal. Мы можем заставить компилятор использовать нужное нам кодирование. Но если по какой-то причине окажется, что значение не соответствует заданной схеме (например, пара бит были изменены из-за ошибки накопителя), то проверить это каким-либо условием будет невозможно, поскольку это выводит наc за область определения типа Signal. Но мы можем написать:

if not The_Signal'Valid then

Атрибут 'Valid применим к любому скалярному объекту. Он возвращает True, если объект содержит корректное, с точки зрения подтипа объекта, значение и False — в противном случае.

Мы можем поступить по-другому. Считать значение, например, как байт, проверить, что значение имеет корректный код, затем преобразовать его к типу Signal, использовав функцию Unchecked_Conversion. Объявим тип Byte и функцию преобразования:

type Byte is range 0 .. 255;

for Byte'Size use 8;

--  Или, в Ада 2012

type Byte is range 0 .. 255 with Size => 8;

function Byte_To_Signal is new

Unchecked_Conversion(Byte, Signal);

затем:

Raw_Signal: Byte;

for Raw_Signal'Address use To_Address(16#ACE#);

--  Или, в Ада 2012

Raw_Signal: Byte with Address => To_Address(16#ACE#);

The_Signal: Signal;

case Raw_Signal is

when 1 | 2 | 4 =>

The_Signal := Byte_To_Signal (Raw_Signal);

when others =>

... -- Значение не корректно

end case;

Поскольку Byte - это обычный целочисленный тип, мы можем использовать любые арифметические операции, чтобы проверить полученное значение. При получении некорректного значения мы можем предпринять соответствующие действия, например запротоколировать его и т. д.

Отметим, что данный код не будет работать, если загружаемое значение меняется самопроизвольно. Значение может поменяться после проверки и до преобразования. Поэтому, сначала значение должно быть скопировано в локальную переменную.

Взаимодействие с другими языками

Многие большие современные системы написаны на нескольких языках программирования, каждый из которых больше подходит для своей части системы. Части с повышенными требованиями к безопасности и надежности могут быть написаны на Аде (например, с использованием SPARK), графический интерфейс на C++, какой-нибудь сложный математический анализ на Fortran, драйвера устройств на C, и т. д.

Многие языки имеют механизмы взаимодействия с другими языками (например, использование C из C++), хотя обычно они определены довольно неряшливо. Уникальность языка Ады в том, что он предоставляет четко определенные механизмы взаимодействия с другими языками в целом. В Аде есть средства взаимодействия с языками C, C++, Fortran и COBOL. В частности, Ада поддерживает внутреннее представление типов данных из этих языков, в том числе учитывает порядок строк и столбцов в матрицах Fortran и представление строк в C.

Во многоязычной системе имеет смысл использовать язык Ада, как центральный, чтобы воспользоваться преимуществами ее системы контроля типов.

Средства взаимодействия в своей основе используют директивы компилятору (pragma). Предположим, существует функция next_int на языке C и мы хотим вызвать ее из Ады. Достаточно написать:

function Next_Int return Interfaces.C.int;

pragma Import (C, Next_Int);

Эта директива указывает, что данная функция имеет соглашение о вызовах языка C, и что в Аде не будет тела для этой функции. В ней также возможно указать желаемое внешнее имя и имя для редактора связей, если необходимо. Предопределенный пакет Interfaces.C предоставляет объявления различных примитивных типов языка C. Использование этих типов позволяет нам абстрагироваться от того, как типы языка Ада соотносятся с типами языка C.

Аналогично, если мы хотим дать возможность вызывать процедуру Action, реализованную на языке Ада из C, мы сделаем имя этой процедуры доступным извне, написав:

procedure Action(X,Y: in Interfaces.C.int);

pragma Export (C, Action);

Ссылки на подпрограммы играют важную роль во взаимодействии с другими языками, особенно при программировании интерактивных систем. Предположим, мы хотим, чтобы процедура Action вызывалась из графического интерфейса при нажатии на кнопку мыши. Допустим, есть функция set_click на C, принимающая адрес подпрограммы, вызываемой при нажатии. На Аде мы выразим это так:

type Response is access procedure (X,Y: in Interfaces.C.int);

pragma Convention (C, Response);

procedure Set_Click(P: in Response);

pragma Import(C, Set_Click);

procedure Action(X,Y: in Interfaces.C.int);

pragma Convention(C, Action);

...

Set_Click(Action'Access);

В этом случае, мы не делаем имя процедуры Action видимым из программы на C, поскольку ее вызов будет происходить косвенно, но мы гарантируем, что соглашения о вызовах будут соблюдены.

Потоки ввода/вывода

При передаче значений различных типов во внешний мир и обратно мы можем столкнуться с некоторыми трудностями. Вывод значений достаточно прямолинеен, поскольку мы заранее знаем типы этих значений. Ввод может быть проблематичным, так как мы обычно не знаем, какой тип может прийти. Если файл содержит значения одного типа, то все просто, нужно лишь убедиться, что мы не перепутали файл. Настоящие затруднения начинаются, если файл содержит значения различных типов. Ада предлагает механизмы работы как с гомогенными файлами (например, файл из целых чисел или текстовый файл), так и с гетерогенными файлами. Механизм работы с последними использует потоки.

В качестве простого примера, рассмотрим файл, содержащий значения Integer, Float и Signal. Все типы имеют специальные атрибуты 'Read и 'Write для использования потоков. Для записи мы просто напишем:

S: Stream_Access := Stream(The_File);

...

Integer'Write(S, An_Integer);

Float'Write(S, A_Float);

Signal'Write(S, A_Signal);

и в результате получим смесь значений в файле The_File. Для экономии места опустим детали, скажем только, что S обозначает поток, связанный с файлом.

При чтении мы напишем обратное:

Integer'Read(S, An_Integer);

Float'Read(S, A_Float);

Signal'Read(S, A_Signal);

Если мы ошибемся в порядке, от получим исключение Data_Error в том случае, если прочитанные биты не отображают корректное значение нужного типа.

Если мы не знаем заранее, в каком порядке идут данные, мы должны создать класс, покрывающий все возможные типы. В нашем случае, объявим базовый тип:

type Root is abstract tagged null record;

выполняющий роль обвертки, затем серию типов для возможных вариантов:

type S_Integer is new Root with record

Value: Integer;

end record;

type S_Float is new Root with record

Value: Float;

end record;

и так далее. Запись примет следующий вид:

Root'Class'Output(S, (Root with An_Integer));

Root'Class'Output(S, (Root with A_Float));

Root'Class'Output(S, (Root with A_Signal));

Заметьте, что тут во всех случаях используется одна и та же подпрограмма. Она сначала записывает значение тега конкретного типа, а затем вызывает (с помощью диспетчеризации) соответствующий 'Write атрибут.

При чтении мы могли бы написать:

Next_Item: Root'Class := Root'Class'Input(S);

...

Process(Next_Item);

Процедура Root'Class'Input читает тег из потока и затем вызывает нужный 'Read атрибут для чтения всего объекта, а затем присваивает полученное значение переменной Next_Item. Далее мы можем обработать полученное значение, например, вызвав диспетчеризируемую подпрограмму Process. Пусть ее задачей будет присвоить полученное значение нужной переменной, согласно типу.

Для начала объявим абстрактную процедуру для базового типа:

procedure Process(X: in Root) is abstract;

затем конкретные варианты:

overriding procedure Process(X: S_Integer) is

begin

An_Integer := X.Value; -- достаем значение из обвертки

end Process;

Безусловно, процедура Process может делать все, что мы захотим с полученным значением.

Возможно, данный пример выглядит немного искусственным. Его цель проиллюстрировать, что в Аде возможно обрабатывать элементы различных типов, сохранив при этом безопасную строго типизированную модель данных.

Фабрики объектов

Мы только что видели, как стандартный механизм потоков позволяет нам обрабатывать значения различных типов, поступающих из файла. Лежащий в основе механизм чтения тега и затем создания объекта соответствующего типа стал доступен пользователю в Аде 2005.

Допустим, мы обрабатываем геометрические объекты, которые мы обсуждали в главе «Безопасное ООП». Различные типы, такие как Circle, Square, Triangle и т. д. наследуются от базового типа Geometry.Object. Нам может понадобиться вводить эти объекты с клавиатуры. Для окружности нам понадобиться две координаты и радиус. Для треугольника — координаты и длины трех сторон. Мы могли бы объявить функцию Get_Object для создания объектов, например для окружности:

function Get_Object return Circle is

begin

return C: Circle do

Get(C.X_Coord); Get(C.Y_Coord); Get(C.Radius);

end return;

end Get_Object;

Внутренние вызовы Get это стандартные процедуры для чтения значения примитивных типов с клавиатуры. Пользователь должен ввести какой-то код, чтобы обозначить, какого рода объект он хочет создать. Предположим, что ввод окружности обозначается строкой "Circle". Также предположим, что у нас уже есть функция для чтения строки Get_String.

Теперь нам остается только прочесть код и вызвать соответствующую процедуру Get_Object для создания объекта. Для этого мы воспользуемся предопределенной настраиваемой функцией, которая получает тег и возвращает сконструированный объект. Вот ее определение:

generic

type T(<>) is abstract tagged limited private;

with function Constructor return T is abstract;

function Generic_Dispatching_Constructor(The_Tag: Tag)

return T'Class;

Эта настраиваемая функция имеет два параметра настройки. Первый определяет конструируемый класс типов (в нашем случае Geometry.Object, от которого происходят Circle, Square и Triangle). Второй - это диспетчеризируемая функция для создания объектов (в нашем случае Get_Object).

Теперь мы настроим ее и получим функцию создания геометрических объектов:

function Make_Object is new

Generic_Dispatching_Constructor(Object, Get_Object);

Эта функция принимает тег типа создаваемого объекта, вызывает соответствующую Get_Object и возвращает полученный результат.

Мы могли бы определить ссылочную переменную для хранения вновь созданных объектов:

Object_Ptr: access Object'Class;

Если тег хранится в переменной Object_Tag (имеющую тип Tag из пакета Ada.Tags, там же объявлена и функция Generic_Dispatching_Constructor), то мы вызовем Make_Object так:

Object_Ptr := new Object'(Make_Object(Object_Tag));

и получим новый объект (например окружность), чьи координаты и радиус были введены с клавиатуры.

Чтобы закончить пример, нам осталось научиться преобразовывать строковые коды объектов, такие как "Circle", в теги. Простейший случай сделать это — определить атрибут 'External_Tag:

for Circle'External_Tag use "Circle";

for Triangle'External_Tag use "Triangle";

тогда прочесть строку и получить тег можно так:

Object_Tag: Tag := Internal_Tag(Get_String);

Конечно, использовать отдельную переменную Object_Tag не обязательно, поскольку мы можем объединить эти операции в одну:

Object_Ptr := new Object'(Make_Object(Internal_Tag(Get_String));

Напоследок следует заметить, что приведенный код немного упрощен. На самом деле настраиваемый конструктор имеет вспомогательный параметр, который мы опустили.

Footnotes

Безопасный параллелизм

В реальной жизни многие процессы протекают одновременно. Люди делают несколько вещей одновременно с поразительной легкостью. Кажется, женщины преуспевают в этом лучше мужчин, возможно потому, что им нужно баюкать малыша, одновременно готовя еду и отгоняя тигра от пещеры. Мужчины же обычно концентрируются на одной проблеме за раз, ловят кролика на обед, либо ищут большую пещеру, либо, возможно, даже изобретают колесо.

Традиционно компьютер делает одно действие в каждый конкретный момент времени, а операционная система затем делает вид, будто несколько процессов выполняются одновременно. Положение дел меняется в наши дни, поскольку многие машины сейчас имеют несколько процессоров или ядер, но это все еще так, когда речь идет о огромном числе небольших систем, в том числе используемых в управлении производством.

Операционные системы и задачи

Степень параллельности, доступная в разных операционных системах, может быть совершенно разная. Операционные системы с поддержкой POSIX позволяют программисту создать несколько потоков управления. Эти потоки исполняют программу довольно независимо друг от друга и, таким образом, реализуют параллельное программирование.

На некоторых системах есть всего один процессор и он будет исполнять различные потоки в соответствии с некоторым алгоритмом планирования. Один из вариантов — просто выделять небольшой интервал времени каждому потоку по очереди. Более сложные алгоритмы (особенно для систем реального времени) используют приоритеты и предельные сроки, чтобы гарантировать, что процессор используется эффективно.

Другие системы имеют несколько процессоров. В этом случае некоторые потоки выполняются действительно параллельно. Здесь тоже используется планировщик, который распределяет процессоры для исполнения активных потоков по возможности эффективно.

В языках программирования параллельные процессы обычно называют потоки или задачи. Здесь мы используем второй вариант, который соответствует терминологии Ады. Существуют различные подходы к вопросу параллельности в разных языках. Одни предлагают многозадачные средства, встроенные непосредственно в язык. Другие просто предоставляют доступ к соответствующим примитивам операционной системы. Есть и такие, которые полностью игнорируют этот вопрос.

Ада, Java, C# и последние версии C++ среди тех языков, где поддержка параллельности встроена в язык. В C нет такой поддержки и программистам приходится пользоваться внешними библиотеками или напрямую вызывать сервисы операционной системы.

Есть, как минимум, три преимущества, когда язык имеет встроенные средства поддержки многозадачности:

- Встроенный синтаксис существенно облегчает написание корректных программ, поскольку язык может предотвратить появление множества видов ошибок. Здесь опять проявляет себя принцип абстракции. Мы избегаем ошибок, скрывая различные низкоуровневые детали.

- При использовании средств операционной системы напрямую существенно затрудняется переносимость, поскольку одна система может значительно отличаться от другой.

- Операционные системы общего назначения не предоставляют средства, необходимые для различных приложений систем реального времени.

Многозадачной программе обычно нужны следующие условия:

- Необходимо предотвратить нарушение целостности данных, когда нескольким задачам требуется доступ к одним данным.

- Необходимо предоставить средства межзадачного взаимодействия для передачи данных от одной задачи к другой.

- Необходимы средства управления задачами с целью гарантирования специфичных временных условий.

- Необходим планировщик выполнения задач для эффективного использования ресурсов и попадания в установленные временные границы.

В этой главе мы кратко остановимся на этих вопросах и продемонстрируем надежные способы их решения, применяемые в языке Ада. Реализация многозадачности влечет целый спектр сложных моментов, поскольку написать корректную многозадачную программу намного труднее, чем чисто последовательную. Но сначала мы рассмотрим простую концепцию задачи в языке Ада и общую структуру программы.

В Аде программа может иметь множество задач, исполняющихся одновременно. Задача имеет две части, так же, как и пакет. Первая часть - это спецификация задачи. Она описывает интерфейс взаимодействия с другими задачами. Вторая часть - это тело задачи, где описывается, что собственно происходит. В простейшем случае спецификация задает лишь имя задачи и выглядит так:

task A; --  Спецификация задачи

task body A is      --  Тело задачи

begin

...   --  инструкции, определяющие что делать

end A;

Бывают случаи, когда удобно иметь несколько одинаковых задач, тогда мы объявляем задачный тип:

task type Worker;

task body Worker is ...

После чего мы можем объявить несколько задач так же, как мы объявляем объекты:

Tom, Dick, Harry: Worker;

Тут мы создали три задачи Tom, Dick, Harry. Мы можем объявлять массивы задач, делать компоненты записи и прочее. Задачи можно объявлять всюду, где можно объявлять объекты, например в пакете, в подпрограмме или даже в другой задаче. Не удивительно, что задачи имеют лимитированный тип, поскольку нет смысла присваивать одной задаче другую.

Главная подпрограмма всей программы вызывается из так называемой задачи окружения. Именно эта задача выполняет предвыполнение пакетов библиотечного уровня, как описано в главе «Безопасный запуск». Таким образом, программу с тремя пакетами A, B и C и главной процедурой Main можно представить, как:

task type Environment_Task;

task body Environment_Task is

... -- объявления пакетов A, B, C

... -- и главной процедуры Main

begin

... -- вызов процедуры Main

end Environment_Task;

Задача становится активной сразу после объявления. Она завершается, когда исполнение доходит до конца тела задачи. Существует важное правило, локальная задача (т. е. та, что объявлена внутри подпрограммы, блока или другой задачи) должна завершиться до того, как управление покинет охватывающий ее блок. Исполнение окружающего блока приостанавливается до тех пор, пока вложенная задача не завершится. Это правило предотвращает появление висящих ссылок на несуществующие более объекты.

Защищенные объекты

Допустим, три задачи - Tom, Dick и Harry используют общий стек для временного хранения данных. Время от времени одна из них кладет элемент в стек, затем, время от времени, одна из них (возможна та же, а возможно другая) достает данные из стека.

Три задачи исполняются параллельно, возможно на многопроцессорной машине, либо под управлением планировщика на однопроцессорной машине, в которой ОС выделяет кванты процессорного времени каждой задаче. Допустим второе и кванты длинной 10мс выделяются задачам по очереди.

Пусть задачи используют стек из главы «Безопасная архитектура». Пусть квант, выделенный задаче Harry, истекает при вызове Push, затем управление передается задаче Tom, вызывающей Pop. Говоря более конкретно, пусть Harry теряет управление сразу после увеличения переменной Top

procedure Push(X: Float) is

begin

Top := Top + 1; -- после этого Harry теряет управление

A(Top) := X;

end Push;

В этот момент Top уже имеет новое значение, но новое значение X еще не помещено в массив. Когда задача Tom вызовет Pop, она получит старое, скорее всего бессмысленное значение, которое должно было быть переписанным новым значением X. Когда задача Harry получит управление назад (допустим к этому моменту не было других операций со стеком), она запишет значение X в элемент массива, который находится за вершиной стека. Другими словами, значение X будет потеряно.

Еще хуже обстоят дела, когда задачи переключаются посреди выполнения инструкции языка. Например, Harry считал значение Top в регистр, но новое значение Top не успел сохранить, и тут переключился контекст. Далее, пусть Dick вызывает Push, таким образом увеличивает Top на единицу. Когда Harry продолжит исполнение, он заменит Top устаревшим значением. Таким образом, два вызова Push увеличивают Top лишь на 1, вместо 2.

Такое нежелательное поведение может быть предотвращено благодаря использованию защищенного объекта для хранения стека. Такая возможность появилась в стандарте Ада 95. Мы напишем:

protected Stack is

procedure Clear;

procedure Push(X: in Float);

procedure Pop(X: out Float);

private

Max: constant := 100;

Top: Integer range 0 .. Max := 0;

A: Float_Array(1 .. Max);

end Stack;

protected body Stack is

procedure Clear is

begin

Top := 0;

end Clear;

procedure Push(X: in Float) is

begin

Top := Top + 1;

A(Top) := X;

end Push;

procedure Pop(X: out Float) is

begin

X := A(Top);

Top := Top - 1;

end Pop;

end Stack;

Отметьте, как package поменялось на protected, данные из тела пакета переместились в private часть, функция Pop превратилась в процедуру. Мы предполагаем, что тип Float_Array объявлен в другом месте, как array (Integer range <>) of Float.

Три процедуры Clear, Push и Pop называются защищенными операциями и вызываются аналогично обычным процедурам. Отличие состоит в том, что только одна задача может получить доступ к операциям объекта в один момент времени. Если задача, такая как Tom, пытается вызвать процедуру Pop, пока Harry исполняет Push, то Tom будет приостановлен, пока Harry не покинет Push. Это выполняется автоматически, без каких-то усилий со стороны программиста. Таким образом мы избежим несогласованности данных.

За кулисами защищенного объекта лежит механизм блокировок. Перед исполнением операции этого объекта, задача должна сначала захватить блокировку. Если другая задача уже захватила блокировку, первая задача будет ждать, пока другая задача закончит исполнять операцию и отпустит блокировку. (Блокировка может быть реализована с помощью примитивов операционной системы, но также возможны реализации с меньшими накладными расходами.)

Мы можем усовершенствовать наш пример, чтобы показать, как справиться с переполнением или опустошением стека. В первом варианте обе этих ситуации приводят к исключению Constraint_Error. В случае с Push, это происходит при попытке присвоить переменной Top значение Max+1; аналогичная проблема проявляется с Pop. При возбуждении исключения блокировка автоматически снимется, когда исключение завершит вызов процедуры.

Чтобы избежать переполненния и опустошения стека, мы используем барьеры:

protected Stack is

procedure Clear;

entry Push(X: in Float);

entry Pop(X: out Float);

private

Max: constant := 100;

Top: Integer range 0 .. Max := 0;

A: Float_Array(1 .. Max);

end Stack;

protected body Stack is

procedure Clear is

begin

Top := 0;

end Clear;

entry Push(X: in Float) when Top < Max is

begin

Top := Top + 1;

A(Top) := X;

end Push;

entry Pop(X: out Float) when Top > 0 is

begin

X := A(Top);

Top := Top - 1;

end Pop;

end Stack;

Операции Push и Pop теперь входы (entry), а не процедуры, и у них появились барьеры, логические условия, такие как Top < Max. Вход не может принять исполнение, пока условие его барьера ложно. Заметьте, что это не значит, что такой вход нельзя вызвать. Просто вызывающая задача будет приостановлена до тех пор, пока условие не станет истинно. Например, если задача Harry пытается вызвать Push, когда стек заполнен, она должна дождаться, пока какая-нибудь другая задача (Tom или Dick) вызовет Pop и освободит верхний элемент. После этого исполнение Harry автоматически продолжится. Это произойдет без дополнительных действий программиста.

Заметьте, что вызов входа или защищенной процедуры выполняется так же, как и вызов обычной процедуры

Stack.Push (Z);

Подведем итог. Механизм защищенных объектов языка Ада обеспечивает эксклюзивный доступ к общим данным. В видимой части защищенного объекта объявляются защищенные операции, а защищаемые объектом компоненты объявляются в приватной части. Тело защищенного объекта содержит реализацию защищенных операций. Защищенные процедуры и входы предоставляют возможность читать/писать защищаемые данные, в то время, как защищенные функции — только читать. Это ограничение позволяет нескольким задачам читать общие данные одновременно (при использовании защищенных функций), но лишь одна задача может менять их. Из-за запрета защищенным функциям изменять данные нам пришлось переписать Pop как процедуру, хотя в изначальном варианте это была функция.

Аналогично задачам, мы можем объявить защищенный тип, чтобы использовать его как шаблон для создания защищенных объектов. Аналогично задачному типу, защищенный тип также является лимитированным.

Было бы поучительно рассмотреть, как мы запрограммировали бы этот пример, используя низкоуровневые примитивы. Исторически сложилось, что таким примитивом считается объект семафор, у которого определены две операции P (захватить) и V (освободить). Эффект операции P(sem) состоит в захвате блокировки, соответствующей sem, если блокировка свободна, в противном случае задача приостанавливается и помещается в очередь к sem. Эффект V(sem) состоит в том, чтобы снять блокировку и разбудить одну из задач очереди, если она есть.

Чтобы обеспечить эксклюзивный доступ к данным, мы должны окружить каждую нашу операцию парой вызовов P и V. Например Push будет таким:

procedure Push(X: in Float) is

begin

P(Stack_Lock); --  захватить блокировку

Top := Top + 1;

A(Top) := X;

V(Stack_Lock); --  освободить блокировку

end Push;

Аналогично делается для подпрограмм Clear и Pop. Так обычно пишут многозадачный код на ассемблере. При этом есть множество возможностей совершить ошибку:

- Можно пропустить одну из операций P или V, нарушив баланс блокировок.

- Можно забыть поставить обе операции и оставить нужный код без защиты.

- Можно перепутать имя семафора.

- Можно случайно обойти вызов закрывающей операции V при исполнении.

Последняя ошибка могла бы возникнуть, например, если в варианте без барьеров, Push вызывается при заполненном массиве. Это приводит к возбуждению исключения Constraint_Error. Если мы не напишем обработчик исключения, где будем вызывать V, объект останется заблокированным навсегда.

Все эти трудности не возникают, если пользоваться защищенными объектами языка Ада, поскольку все низкоуровневые действия выполняются автоматически. Если действовать осторожно, можно обойтись семафорами в простых случаях, но очень сложно получить правильный результат в более сложных ситуациях, таких, как наш пример с барьерами. Сложно не только написать правильную программу, но также чрезвычайно сложно доказать, что программа корректна.

Входы с барьерами являются механизмом более высокого уровня, чем механизм «условных переменных», который можно найти в других языках программирования. Например, в языке Java, программист обязан явно вызывать wait, notify и notifyAll для переменных, отражающих состояния объекта, такие как «стек полон» и «стек пуст». Этот подход чреват ошибками и подвержен ситуации гонки приоритетов, в отличии от механизмов Ады.

Рандеву

Еще одним средством поддержи многозадачности является возможность непосредственного обмена данными между двумя задачами. В Аде это реализовано с помощью механизма рандеву. Две взаимодействующие задачи вступают в отношение клиент-сервер. Сервер должен быть известен клиенту, нуждающемуся в каком-то его сервисе. В то же время серверу безразлично, какого клиента он обслуживает.

Вот общий вид сервера, предоставляющего единственный сервис:

task Server is

entry Some_Service(Format: in out Data);

end;

task body Server is

begin

...

accept Some_Service(Format: in out Data) do

... -- код предоставляющий сервис

end Some_Service;

end Server;

По спецификации сервера видно, что он имеет вход Some_Service. Этот вход может быть вызван точно так же, как вход защищенного объекта. Отличие в том, что код, предоставляющий сервис, находится в соответствующей инструкции принятия (accept), которая исполняется лишь когда до нее доходит поток исполнения сервера. До этого момента вызывающая задача будет ожидать. Когда сервер достигнет инструкции принятия, она будет исполнена, используя любые параметры, переданные клиентом. Клиент будет ожидать окончания исполнения инструкции принятия, после чего все параметры out и in out получат новые значения.

Тело клиента может выглядеть так:

task body Client is

Actual: Data;

begin

...

Server.Some_Service (Actual);

...

end Client;

Каждый вход имеет соответствующую очередь. Если задача вызывает вход, а сервер в этот момент не ожидает на инструкции принятия, то задача ставится в очередь. С другой стороны, если сервер достигает инструкции принятия, а очередь пуста, то останавливается сервер. Инструкция принятия может находиться в любом месте в теле задачи, где допускаются инструкции, например, в одной из ветвей условной инструкции (if) или внутри цикла. Этот механизм очень гибкий.

Рандеву - это механизм высокого уровня (как и защищенные объекты), следовательно, его легко применять правильно. Соответствующий низкоуровневый механизм очередей тяжело использовать без ошибок.

Теперь приведем пример использования рандеву, в котором клиенту не нужно ожидать. Идея в том, что клиент передает серверу ссылку на вход, который необходимо вызвать, когда работа будет выполнена. Сначала мы объявим своего рода почтовый ящик, для обмена элементами некоторого типа Item, который определен где-то ранее:

task type Mailbox is

entry Deposit(X: in Item);

entry Collect(X: out Item);

end Mailbox;

task Mailbox is

Local: Item;

begin

accept Deposit(X: in Item) do

Local := X;

end;

accept Collect(X: out Item) do

X := Local;

end;

end Mailbox;

Мы можем положить элемент в Mailbox, чтобы забрать его позже. Клиент передаст ссылку на почтовый ящик, куда сервер положит элемент, а клиент заберет его там позже. Нам понадобится ссылочный тип:

type Mailbox_Ref is access Mailbox;

Клиент и сервер будут следующего вида:

task Server is

entry Request(Ref: in Mailbox_Ref; X: in Item);

end;

task body Server is

Reply: Mailbox_Ref;

Job: Item;

begin

loop

accept Request(Ref: in Mailbox_Ref; X: in Item) do

Reply := Ref;

Job := X;

end;

...

-- выполняем работу

Reply.Deposit(Job);

end loop;

end Server;

task Client;

task body Client is

My_Box: Mailbox_Ref := new Mailbox;

-- создаем задачу-почтовый ящик

My_Item: Item;

begin

Server.Request(My_Box, My_Item);

...

-- занимаемся чем-то пока ждем

My_Box.Collect(My_Item);

end Client;

На практике клиент мог бы время от времени проверять почтовый ящик. Это легко реализовать, используя условный вызов входа:

select

My_Box.Collect (My_Item);

-- успешно получили элемент

else

-- элемент еще не готов

end select;

Почтовый ящик служит нескольким целям. Он отделяет операцию «положить элемент» от операции «взять элемент», что позволяет серверу сразу заняться следующим заданием. Кроме этого, он позволяет серверу ничего не знать о клиенте. Необходимость прямого вызова клиента привела бы к необходимости всегда иметь клиентов одного конкретного задачного типа, что совсем непрактично. Почтовый ящик позволяет нам очертить единственное необходимое свойство клиента — существование вызова Deposit.

Ограничения

Директива компилятору pragma Restrictions, используемая для запрета использования некоторых возможностей языка, уже упоминалась в главах «Безопасное ООП» и «Безопасное управление памятью».

Существует множество ограничений, касающихся многозадачности. Некоторые были известны еще со времен Ады 95, другие добавлены в Аде 2005 и 2012. Возможности Ады в этой области очень обширны. С их помощью можно создавать совершенно разные приложения реального времени. Но многие из них очень просты и не требуют использования всех возможностей языка. Вот некоторые примеры возможных ограничений:

- No_Task_Hierarchy

- No_Task_Termination

- Max_Entry_Queue_Length => n

Ограничение No_Task_Hierarchy предотвращает создание задач внутри других задач или подпрограмм, таким образом, все задачи будут в пакетах библиотечного уровня. Ограничение No_Task_Termination означает, что все задачи будут исполняться вечно, это часто встречается во многих управляющих приложениях, где каждая задача содержит бесконечный цикл, исполняющий какое-то повторяющееся действие. Следующее ограничение обуславливает максимальное количество задач, ожидающих на одном входе в любой момент времени.

Указание ограничений может дать возможность:

- использовать упрощенную версию библиотеки времени исполнения. В результате можно получить меньшую по объему и более быструю программу, что существенно в области встраиваемых систем.

- формально обосновать некоторые свойства программы, такие как детерминизм, отсутствие взаимных блокировок, способность уложится в указанные сроки исполнения.

Существует множество других ограничений, касающихся многозадачности, которые мы не рассмотрели.

Ravenscar

Особенно важная группа ограничений налагается профилем Ravenscar, который был разработан в середине 1990-х и стандартизирован, как часть языка Ада 2005. Чтобы гарантировать, что программа соответствует этому профилю, достаточно написать:

pragma Profile(Ravenscar);

Использование любой из запрещенных возможностей языка (на них мы остановимся далее) приведет к ошибке компиляции.

Главной целью профиля Ravenscar является ограничение многозадачных возможностей таким образом, чтобы эффект от программы стал предсказуемым. (Профиль был определен Международным Симпозиумом по вопросам Реального Времени языка Ада, который проходил дважды в отдаленной деревне Равенскар на побережье Йоркшира в северо-восточной Англии.)

Профиль определен как набор ограничений плюс несколько дополнительных директив компилятору, касающихся планировщика и других подобных вещей. В этот набор входят три ограничения, приведенные нами ранее — отсутствие вложенных задач, бесконечное исполнение задач, ограничения на максимальный размер очереди входа в один элемент (т. е. только одна задача может ожидать на данном входе).

Оригинальная версия профиля Ravenscar предполагала исполнение программы на однопроцессорной машине. В Аде 2012 в профиль добавили семантику исполнения на многопроцессорной машине при условии, что задачи жестко закреплены за ЦПУ. Мы еще вернемся к этому вопросу.

Совместный эффект всех ограничений состоит в том, что становится возможным сформулировать утверждения о способности данной программы удовлетворять жестким требованиям в целях ее сертификации.

Никакой другой язык не предлагает таких средств обеспечения надежности, какие дает язык Ада с включенным профилем Ravenscar.

Безопасное завершение

В некоторых приложениях (например СУПР) задачи исполняются бесконечно, в других задачи доходят до своего конца и завершаются. В этих ситуациях вопросов, касающихся завершения задачи, не встает. Но бывают случаи, когда задача, предназначенная для бесконечной работы, должна быть завершена, например, по причине некоторой ошибки оборудования задача больше не нужна. Встает вопрос, как немедленно и безопасно завершить задачу. Увы, эти требования противоречат друг другу, и разработчику нужно искать компромисс. К счастью, язык Ада предлагает достаточно гибкие средства, чтобы разработчик смог реализовать нужный компромисс. Но даже если предпочтение отдается быстроте завершения, семантика языка гарантирует, что критические операции будут выполнены до того, как станет возможно завершить задачу.

Важным понятием в этом подходе является концепция региона отложенного прекращения. Это такой участок кода, исполнение которого должно дойти до конца, иначе существует риск разрушения разделяемых структур данных. Примерами могут служить тела защищенных операций и операторов принятия. Заметим, что при исполнении такого региона задача может быть вытеснена задачей с более высоким приоритетом.

Чтобы проиллюстрировать эти понятия, рассмотрим следующую версию задачи сервера:

task Server is

entry Some_Service(Formal: in out Data);

end;

task body Server is

begin

loop

accept Some_Service(Format: in out Data) do

... -- код изменения значения Format

end Some_Service;

end loop;

end Server;

Задача будет исполнять периодически одну и ту же работу. Когда в ней больше не будет потребности, задача зависнет на инструкции принятия. Это напоминает анабиоз без перспективы пробуждения. Не очень приятная мысль и не очень приятный стиль программирования. Программа просто виснет, вместо того, чтобы изящно завершиться.

Есть несколько способов разрешить этот вопрос. Первый — объявить клиентскую задачу специально для того, чтобы выключить сервер, когда клиентских запросов больше не будет. Вот так можно описать задачу-палача:

task Grim_Reaper;

task body Grim_Reaper is

begin

abort Server;

end Grim_Reaper;

Предназначение инструкции abort в том, чтобы прекратить указанную задачу (в нашем случае Server). Но это может быть рискованно - прекратить задачу немедленно, вне зависимости от того, что она делает в данный момент, будто вытащить вилку из розетки. Возможно, Server находится в процессе исполнения инструкции принятия входа Some_Service, и параметр может быть в несогласованном состоянии. Прекращение задачи привело бы к тому, что вызывающая задача получила бы искаженные данные, например, частично обработанный массив. Но, как сказано выше, инструкция принятия имеет «отложенное прекращение». Если будет попытка прекратить задачу в этот момент, то библиотека времени исполнения заметит это (формально, задача перейдет в аварийное состояние), но задача не будет завершена до тех пор, пока длится регион отложенного прекращения, т. е. в нашем случае до конца исполнения инструкции accept.

Даже если завершаемая задача не находится в регионе отложенного прекращения, эффект не обязательно будет мгновенным. Говоря коротко, завершаемая задача перейдет в аварийное состояние, в котором она рассматривается, как своего рода прокаженный. Если какая-либо задача неблагоразумно попытается взаимодействовать с этим несчастным (например, обратившись к одному из входов задачи), то получит исключение Tasking_Error. Наконец, если/когда прерванная задача достигнет любой точки планирования, такой как, вызов входа или инструкция принятия, то ее страданию прийдет конец и она завершится. (Для реализаций, поддерживающих Приложение Систем Реального Времени, требования к прекращению более жесткие: грубо говоря, аварийная задача завершится, как только окажется вне региона отложенного прекращения.)

Это может выглядеть немного гнетуще и сложно, и действительно, использование инструкции прекращения затрудняет написание программы, а применение формальных методов затрудняет еще больше. Популярный совет тут - «не делайте так». Можно использовать прекращение, когда нужно, например, сменить режим работы и завершить целое множество задач. В противном случае, лучше использовать одну из следующих техник, когда завершаемая задача сама решает, когда она готова уйти, т. е. завершение возможно только в особых точках.

Следующая техника использует специальный вход для передачи запроса на завершение. Приняв такой вызов, задача затем завершается обычным способом. Вот иллюстрация этой техники:

task Server is

entry Some_Service(Formal: in out Data);

entry Shutdown;

end;

task body Server is

begin

loop

select

accept Shutdown;

exit;

or

accept Some_Service(Format: in out Data) do

... -- код изменения значения Format

end Some_Service;

end select;

end loop;

end Server;

В этой версии применяется форма инструкции select, охватывающая несколько альтернатив, каждая из которых начинается инструкцией принятия входа. При исполнении такой инструкции сначала проверяется, есть ли вызовы, ожидающие приема на этих входах. Если нет, то задача приостанавливается до тех пор, пока не появится такой вызов (в этом случае управление передается на соответствующую ветку). Если такой вызов один, управление передается на нужную ветку. Если несколько, то выбор ветки зависит от политики очередей входов (если реализация поддерживает Приложение Систем Реального Времени, политика, по умолчанию, основывается на приоритетах).

Такая форма инструкции select широко применяется в серверных задачах, когда задача имеет несколько входов, и порядок их вызова (либо количество) заранее не известен. В данном примере порядок вызова входов известен, сначала вызывается Some_Service, а затем Shutdown. Но мы не знаем, сколько раз вызовется Some_Service, поэтому нам понадобился бесконечный цикл.

Как и в предыдущем примере, нам нужна отдельная задача для завершения сервера. Но в этом случае, вместо инструкции прерывания задачи будет вызываться вход Shutdown:

task Grim_Reaper;

task body Grim_Reaper is

begin

Server.Shutdown;

end Grim_Reaper;

При условии, что Grim_Reaper написан корректно, т. е. вызывает Shutdown после всех возможных вызовов Some_Service, подход с использованием Shutdown отвечает нашим требованиям к безопасной остановке задачи. Цена, которую мы платим за это — дополнительная задержка, поскольку завершение не происходит мгновенно.

Ада предлагает еще один подход к завершению, в котором нет необходимости какой-то из задач запускать процесс остановки. Идея состоит в том, что задача завершится автоматически (при содействии библиотеки времени исполнения), когда появится гарантия, что это можно сделать безопасно. Такую гарантию можно дать, если задача, имеющая один или несколько входов, висит на инструкции select и ни одна из ветвей этой инструкции не может быть вызвана. Чтобы это выразить, существует специальный вариант ветви инструкции select:

task Server is

entry Some_Service(Formal: in out Data);

entry Shutdown;

end;

task body Server is

begin

loop

select

terminate;

or

accept Some_Service(Format: in out Data) do

... -- код изменения значения Format

end Some_Service;

end select;

end loop;

end Server;

В этом случае, когда Server дойдет до инструкции select (или будет ожидать на ней), система времени исполнения посмотрит вокруг и определит, есть ли хоть одна живая задача, имеющая ссылку на Server (и таким образом имеющая возможность вызвать его вход). Если таких задач нет, то Server завершится безопасно и это произойдет автоматически. В этом случае нет возможности исполнить какой-либо код для очистки структур данных перед завершением. Но в стандарте Ада 2005 была добавлена возможность определить обработчик завершения, который будет вызван в процессе завершения задачи.

К преимуществам этого подхода относится легкость понимания программы и надежность. Нет риска, как в других вариантах, забыть остановить задачу или остановить ее слишком рано. Недостаток - в существовании накладных расходов, которые несет библиотека времени исполнения при выполнении некоторых операций, даже если эта возможность не используется.

Подведем итог: Ада предоставляет различные возможности и поддерживает различные подходы к завершению задач. Инструкция прерывания имеет наименьшую задержку (хотя и ожидает выхода из регионов с отложенным прерыванием), но могут возникнуть проблемы, когда задача не находится в подходящем для завершения состоянии. Вход для запроса завершения решает эту проблему (задача завершается только когда примет запрос), но увеличивает задержку завершения. Наконец, подход со специальной альтернативой завершения наиболее безопасен (поскольку избавляет от ручного управления завершением задачи), но вводит дополнительные накладные расходы.

Среди возможностей, которые Ада избегает сознательно, возможность асинхронно возбудить исключение в другой задаче. Подобная возможность была, например, в изначальном варианте языка Java. Метод Thread.stop() (теперь считающийся устаревшим) позволяет легко разрушить разделяемые данные, оставив их в несогласованном состоянии. Исключения в Аде всегда выполняются синхронно и не имеют этой проблемы. Конечно, нужно аккуратно подходить к использованию исключений. Например, программист должен знать, что если он не обрабатывает исключения, то задача просто завершится при возникновении исключения, а исключение пропадет. Зато сложностей с асинхронными исключениями удалось избежать.

Время и планирование

Наверное, нельзя закончить главу о многозадачности в Аде, не остановившись на времени и планировании.

Есть инструкции для синхронизации исполнения программы с часами. Мы можем приостановить программу на некоторый промежуток времени (так называемая относительная задержка исполнения), либо до наступления нужного момента времени:

delay 2*Minutes;

delay until Next_Time;

предположим, что существуют объявления для Minutes и Next_Time. Небольшие относительные задержки могут быть полезны для интерактивного использования, в то время как задержка до наступления момента может быть использована для программирования периодических событий. Время можно измерять часами реального времени (они гарантируют некоторую точность), либо локальными часами, подверженными таким фактором, как переход на летнее время. В Аде также учитываются временные зоны и високосные секунды.

В стандарт Ада 2005 были добавлены несколько таймеров, при срабатывании которых вызывается защищенная процедура (обработчик). Есть три типа таймеров. Первый измеряет время ЦПУ, использованное конкретной задачей. Другой измеряет общий бюджет группы задач. Третий основан на часах реального времени. Установка обработчика выполняется по принципу процедуры Set_Handler.

Проиллюстрируем это на забавном примере варки яиц. Мы объявим защищенные объект Egg:

protected Egg is

procedure Boil(For_Time: in Time_Span);

private

procedure Is_Done(Event: in out Timing_Event);

Egg_Time: Timing_Event;

end Egg;

protected body Egg is

procedure Boil(For_Time: in Time_Span) is

begin

Put_Egg_In_Water;

Set_Handler(Egg_Done, For_Time, Is_Done'Access);

end Boil;

procedure Is_Done(Event: in out Timing_Event) is

begin

Ring_The_Pinger;

end Is_Done;

end Egg;

Пользователь напишет так:

Egg.Boil(Minutes (10)); -- лучше сварить вкрутую

-- читаем пока яйцо варится

и будильник зазвенит, когда яйцо будет готово.

Планирование задается директивой компилятору Task_Dispatching_Policy( политика). В Аде 95 определена политика FIFO_Within_Priorities, а в Аде 2005, в Приложении Систем Реального Времени — еще несколько. С помощью этой директивы можно назначить политику всем задачам или задачам, имеющим приоритет из заданного диапазона. Перечислим существующие политики:

- FIFO_Within_Priorities — В пределах каждого уровня приоритета с этой политикой задачи исполняются по принципу первый-пришел-первый-вышел. Задачи с более высоким приоритетом могут вытеснять задачи с меньшим приоритетом.

- Non_Preemtive_FIFO_Within_Priotities — В пределах каждого уровня приоритета с этой политикой задачи исполняются, пока не окончат выполнение, будут заблокированы или выполнят инструкцию задержки (delay). Задача с более высоким приоритетом не может вытеснить их. Эта политика широко используется в приложениях с повышенными требованиями к безопасности.

- Round_Robin_Within_Priotities — В пределах каждого уровня приоритета с этой политикой задачам выделяются кванты времени заданной продолжительности. Эта традиционная политика применяется с первых дней появления параллельных программ.

- EDF_Across_Priotities — EDF это сокращение Earliest Deadline First. Общая идея следующая. На заданном диапазоне уровней приоритета каждая задача имеет крайний срок исполнения (deadline). Исполняется та, у которой это значение меньше. Это новая политика. Для ее использования разработан специальный математический аппарат.

Ада позволяет устанавливать и динамически изменять приоритеты задач и так называемые граничные приоритеты защищенных объектов. Это позволяет избежать проблемы инверсии приоритетов, как описано в [9].

Стандарт Ада 2012 ввел множество полезных усовершенствований, касающихся времени и планирования. Большинство из них не касаются темы этого буклета, но мы затронем здесь один из вопросов, теперь отраженный в стандарте — поддержка многопроцессорных/многоядерных платформ. Эта проблема включает следующие возможности:

- Пакет System.Multiprocessors, где определена функция, возвращающая количество ЦПУ.

- Новый аспект, позволяющий назначить задачу данному ЦПУ.

- Дочерний пакет System.Multiprocessors.Dispatching_Domains позволяет выделить диапазон процессоров, как отдельный «домен диспетчеризации», а затем назначать задачи на исполнение этим доменом либо с помощью аспектов, либо при помощи вызова подпрограммы. После этого задача будет исполняться любым ЦПУ из заданного диапазона.

- Определение директивы компилятору Volatile поменяли. Теперь она гарантирует корректный порядок операций чтения и записи вместо требования указанной переменной находиться в памяти, как было раньше.

Footnotes

Сертификация с помощью SPARK

В областях с повышенными требованиями к безопасности и надежности приложение обязанно быть корректным. Эта корректность обеспечивается специальными формальными процедурами. Когда дело касается безопасности, ошибка в приложении может стоить человеческой жизни или катастрофы (или просто быть очень дорогой, как, например, ошибки в управлении космическими аппаратами и ракетами). Ошибка в особо надежных приложениях может привести к компрометации национальной безопасности, утрате коммерческой репутации или просто к краже.

Приложения можно классифицировать согласно последствий от сбоя программного обеспечения. Стандарты авиационной безопасности DO-178B [1] и DO-178C [2] предлагают следующую классификацию:

- Уровень E никакой: нет проблем. Пример — отказала развлекательная система? Это даже прикольно!

- Уровень D низкий: некоторое неудобство. Пример — отказала система автоматического туалета.

- Уровень C высокий: некоторые повреждения. Пример — жесткая посадка, порезы и ушибы.

- Уровень B опасный: есть жертвы. Пример — неудачная посадка с пожаром.

- Уровень A катастрофический: авиакатастрофа, все мертвы. Пример — поломка системы управления.

Следует отметить, хотя отказ системы развлечений и относится к уровню E, но, если пилот не может выключить ее (например, чтобы сделать важное объявление), то эта ошибка повышает уровень системы развлечений до D.

Для наиболее критичных приложений, где требуется сертификации в соответствующих органах, недостаточно иметь корректную программу. Необходимо также доказать, что программа корректна, что намного тяжелее. Это требует использования формальных математических методов. Эта и стало причиной возникновения языка SPARK.

Эта глава является кратким введением в SPARK 2014. Это наиболее свежая на данный момент версия языка. В ней используется синтаксис Ада 2012 для указания контрактов, таких как пред- и пост-условия. Таким образом, SPARK 2014 - это подмножество языка Ада 2012 с некоторыми дополнительными возможностями, облегчающими формальный анализ (эти возможности используют механизм аспектов, рассмотренный в главе «Безопасные типы данных»). Программа на Аде 2012 может иметь компоненты, написанные с использованием всех возможностей Ады, и другие компоненты на языке SPARK (которые будут иметь явную отметку об этом). Компоненты на SPARK могут быть скомпилированы стандартным Ада компилятором и будут иметь стандартную Ада семантику во время исполнения, но они лучше поддаются методам формального анализа, чем остальные компоненты.

Компоненты SPARK кроме компиляции стандартным Ада компилятором еще и анализируются с помощью инструментария SPARK. Этот инструментарий может статически удостовериться в исполнении контрактов (таких, как пред-условия и пост-условия), которые обычно проверяются во время исполнения. Как следствие, эти проверки времени исполнения могут быть выключены. Инструментарий SPARK, используемый в GNAT, называется GNATprove. Далее в этой главе мы предполагаем использование для анализа именно этого инструмента.

Важно отметить, что SPARK можно использовать на разных уровнях. На самом простейшем Ада программа, удовлетворяющая подмножеству SPARK, может быть проанализирована без дополнительных усилий. Но мы можем укрепить описание программы, добавив различные аспекты относительно потока информации, что позволит инструментарию провести более скрупулезный анализ программы. В конце концов, пользователь сам выбирает, добавлять или нет данные аспекты, в зависимости от характера проекта, в том числе от требований к необходимому уровню безопасности ПО и политики верификации.

Мы начнем с более подробного рассмотрения основных концепций корректности и контрактов.

Контракты

Что мы подразумеваем под корректным ПО? Наверное, общим определением может быть такое — ПО, которое делает то, что предполагал его автор. Для простой одноразовой программы это может означать просто результат вычислений, в то время как для большого авиационного приложения это будет определиться текстом контракта между программистом и конечным пользователем.

Идея контрактов в области ПО далеко не нова. Если мы посмотрим на библиотеки, разработанные в начале 1960-х, в частности, в математической области, написанные на Algol 60 (этот язык пользовался популярностью при публикации подобных материалов в уважаемых журналах, типа Communications of the ACM и Computer Journal), мы увидим подробные требования к параметрам, ограничения на диапазон их значений и прочее. Суть здесь в том, что вводится контракт между автором подпрограммы и ее пользователем. Пользователь обязуется предоставить подходящие параметры, а подпрограмма обязуется вернуть корректный результат.

Деление программы на различные части - это хорошо известный подход, а сутью процесса программирования является определение этих составных частей и, таким образом, интерфейсов между ними. Это позволяет разрабатывать отдельные части независимо друг от друга. Если мы напишем каждую часть правильно (т. е. они будут выполнять каждая свою часть контракта, определяемого интерфейсом) и если мы правильно определили интерфейсы, то мы можем быть уверены, что, собрав все части вместе, получим функционирующую правильно систему.

Горький опыт говорит нам, что в жизни все не совсем так. Две вещи могут пойти не так: с одной стороны, определения интерфейсов зачастую не являются доскональными (есть дыры в контрактах), с другой стороны, индивидуальные компоненты работают неправильно или используются неправильно (контракты нарушаются). И, конечно, контракты могут диктовать совсем не то, что мы имели ввиду.

Любопытно, что есть несколько способов указать контракты на программные компоненты. В первую очередь, и исторически SPARK настоятельно рекомендует делать так, можно указывать контракты с самого начала. Обычно это называют «корректность с помощью построения», а также «декларативная верификация», когда каждый программный модуль содержит контракт в его спецификации. Контракт можно расценивать, как явно выраженные низкоуровневые требования к программному модулю. Если контракт противоречит коду модуля, то это будет обнаружено до начала исполнения программы. Годы использования SPARK в таких областях, как авиация, банковская сфера, управление железной дорогой, позволяют убедиться, что вероятность получить корректную программу повышается и, более того, общая стоимость разработки, включая фазы тестирования и интеграции, уменьшается.

Хотя такой подход эффективен для новых проектов, его применение может быть затруднительно в случаях доработки существующего ПО. В связи с этим, SPARK поддерживает другой стиль разработки, называемый «порождающая верификация». Если код не содержит контрактов, GNATprove может синтезировать некоторые из них на основе тела модуля. Таким образом, проект может двигаться от порождающей верификации к декларативной по мере развития системы. Более того, как мы объясним далее, SPARK 2014 позволяет разработчикам комбинировать формальные методы с традиционными, основанными на тестировании.

Давайте теперь рассмотрим более подробно два вопроса, касающихся, во первых, исчерпывающего определения интерфейса, во вторых, проверки кода реализации на соответствие интерфейсу. Проще подойти к этому в терминах декларативной верификации, хотя эти же концепции также применимы к методу порождающей верификации.

В идеале, определение интерфейса должно скрывать все несущественные детали, но освещать все существенные. Другими словами, мы можем сказать, что определение интерфейса должно быть одновременно корректным и полным.

В качестве простого интерфейса рассмотрим интерфейс подпрограммы. Как мы уже упоминали, интерфейс должен описывать целиком контракт между пользователем и автором. Детали реализации нам не интересны. Чтобы различать эти два аспекта, полезно использовать два различных языка программирования. Некоторые языки представляют подпрограмму как некий неделимый кусок кода, в котором реализация не отделима от интерфейса. В этом кроется проблема. Это не только затрудняет проверку интерфейса, поскольку компилятор сразу требует код вместе с реализацией, но и поощряет программиста писать код одновременно с формулированием интерфейса, что вносит путаницу в процесс разработки.

Структура программы на Аде разделяет интерфейс (спецификацию) от реализации. Это верно как для отдельных подпрограмм, так и для их групп, объединенных в пакеты. Это главная причина того, почему Ада так хорошо подходит как основа для SPARK.

Как упоминалось ранее, иногда очень удобно, когда только часть программы написана на SPARK, а другие части на Аде. Части SPARK отмечаются с помощью аспекта SPARK_Mode. Он может указываться для отдельных подпрограмм, но удобнее указывать его для всего пакета. Например:

package P

with SPARK_Mode is

...

В добавок к этому, этот режим можно включить при помощи директивы компилятору. Это удобно, если необходимо указать режим для всей программы (используя файл конфигурации gnat.adc):

pragma SPARK_Mode;

Дополнительную информацию об интерфейсе в SPARK можно передать при помощи механизма аспектов Ада 2012. Главная цель использования этих аспектов — увеличить количество информации об интерфейсе без предоставления лишних деталей о реализации. На самом деле, SPARK позволяет использовать информацию разного уровня детализации в зависимости от потребностей приложения.

Рассмотрим информацию предоставляемую следующей спецификацией:

procedure Add(X: in Integer);

Откровенно говоря, здесь ее совсем мало. Извесно только то, что процедура Add принимает единственный параметр типа Integer. Этого достаточно, чтобы компилятор имел возможность создать код для вызова процедуры. Но при этом совершенно ничего не известно о том, что процедура делает. Она может делать все, что угодно. Она вообще может не использовать значение X. Она может, к примеру, находить разность двух глобальных переменных и печатать результат в некоторый файл. Но теперь рассмотрим, что случиться, если если мы добавим SPARK-конструкцию, определяющую, как используются глобальные переменные. Мы предполагаем, что процедура определена в пакете, для которого включен режим SPARK_Mode. Спецификация могла бы быть такой:

procedure Add(X: in Integer)

with Global => (In_Out => Total);

Аспект Global указывает, что единственной переменной, доступной в этой процедуре, является Total. Кроме того, идентификатор In_Out говорит, что мы будем использовать начальное значение Total и вычислим ее новое значение. В SPARK есть дополнительные правила для параметров подпрограмм. Хотя в Аде мы вправе не использовать параметр X вообще, в SPARK параметры с режимом in должны быть использованы в теле подпрограммы. В противном случае мы получим предупреждение.

Теперь мы знаем намного больше. Вызов Add вычислит новое значение Total, использовав для этого начальное значение Total и значение X. Также известно, то Add не может изменить что-либо еще. Определенно, она не может ничего печатать или иметь другие побочные эффекты. (Анализатор обнаружит и отвергнет программу, если эти условия нарушаются.)

Безусловно, такой контракт нельзя считать завершенным, поскольку из него не следует, что используется операция сложения, чтобы получить новое значение Total. Указать это можно с помощью пост-условия:

procedure Add (X: in Integer)

with Global => (In_Out => Total),

Post   => (Total = Total'Old + X);

Пост-условие однозначно определяет, что новое значение Total равно сумме начального значения (обозначенного как 'Old) и значения X. Теперь спецификация завершена.

Также есть возможность указать пред-условие. Мы можем потребовать, чтобы X было положительным и при сложении не возникло переполнение. Это можно сделать следующим образом:

Pre => X > 0 and then Total <= Integer'Last - X

(Ограничение на положительные значения X лучше было бы выразить, использовав тип Positive в объявлении параметра X. Мы включили это в предусловие лишь в демонстрационных целях.)

Пред- и пост-условия, как и все аспекты SPARK, не являются обязательными. Если они не указаны явно, предполагается значение True.

Еще один аспект, который можно указать, это Depends. Он определяет зависимости между начальными значениями параметров и переменных и их конечными значениями. В случае с Add это выглядит так:

Depends => (Total => (Total, X))

Здесь просто сказано, что конечное значение Total зависит от его начального значения и значения X. Однако, в этом случае, это и так можно узнать из режима параметра и глобальной переменной, поэтому это не дает нам новой информации.

Как мы уже говорили, все SPARK-аспекты являются необязательными. Но, если они указаны, то будут статически верифицированы при анализе тела подпрограммы.

В случае с пред- и пост-условием будет сделана попытка доказать следующее:

Если предусловие истинно, то (1) не произойдет ошибок времени исполнения и (2) если подпрограмма завершится, то постусловие будет выполнено.

Если контракт не будет верифицирован (например, GNATProve не сможет доказать истинность пред- и пост-условий), то анализатор отвергнет модуль, но компилятор Ада все еще может скомпилировать его, превратив пред- и пост-условия в проверки времени исполнения (если Assertion_Policy равна Check). Таким образом, использование общего синтаксиса для Ада 2012 и SPARK 2014 предоставляет значительную гибкость. Например, разработчик сначала может применять проверки во время исполнения, а затем, когда код и контракт будут отлажены, перейти к статической верификации.

Для критических систем данная статическая верификация очень важна. В этой области нарушение контракта во время исполнения недопустимо. Узнать, что условие не выполнено только в момент исполнения, это не то, что нам нужно. Допустим, у нас есть пред-условие для посадки самолета:

procedure Touchdown(...)

with Pre => Undercarriage_Down; -- шасси выпущено

Узнать о том, что шасси не выпущено только в момент посадки самолета будет слишком поздно. На самом деле, мы хотим быть уверены, что программа была проанализирована заранее и гарантируется, что такая ситуация не возникнет.

Это подводит нас к следующему вопросу гарантий того, что реализация корректно исполняет интерфейсный контракт. Иногда это называют отладкой. Вообще есть четыре способа обнаружить ошибку:

1. С помощью компилятора. Такие ошибки обычно исправить легко, потому что компилятор говорит нам, что не так. 1. Во время исполнения с помощью проверок, определенных языком. Например, язык гарантирует, что мы не обращаемся к элементу за пределами массива. Обычно мы получаем сообщение об ошибке и место в программе, где она произошла. 1. При помощи тестирования. В этом случае мы запускаем какие-то примеры и размышляем над неожиданными результатами, пытаясь понять, что пошло не так. 1. При крахе программы. Обычно после краха остается очень мало данных и поиск причины может быть очень утомительным.

Первый тип, на самом деле, должен быть расширен, чтобы обозначать «до начала исполнения программы». Таким образом, он включает сквозной контроль программы и другие рецензирующие методы, в том числе статический анализ инструментарием типа GNATprove.

Очевидно, что эти четыре способа указаны в порядке возрастания трудности. Ошибки тем легче локализовать и исправить, чем раньше они обнаружены. Хорошие средства программирования позволяют переместить ошибки из категории с большим номером в категорию с меньшим. Хороший язык программирования предоставляет средства, позволяющие оградить себя от ошибок, которые трудно найти. Язык Ада хорош благодаря строгой типизации и проверкам времени исполнения. Например, правильное использование перечислимых типов превращает сложные ошибки типа 3 в простые ошибки типа 1, как мы продемонстрировали в главе «Безопасные типы данных».

Главная цель языка SPARK состоит в том, чтобы за счет усиления определения интерфейса (контрактов) переместить все ошибки из других категорий, в идеале, в категорию 1, для того, чтобы обнаружить их до момента запуска приложения. Например, аспект Globals предотвращает случайное изменение глобальных переменных. Аналогично, обнаружение потенциальных нарушений пред- и пост-условий выливается в ошибки 1-го типа. Однако, проверка, что такие нарушения невозможны, требует математических доказательств. Это не всегда просто, но GNATprove способен автоматизировать большую часть процесса доказательства.

SPARK — подмножество языка Ада

Ада - это довольно сложный язык программирования и использование всех его возможностей затрудняет полный анализ программы. Соответственно, подмножество языка Ада, используемое в SPARK, ограничивает набор доступных средств. В основном, это касается поведения во время исполнения. Например, отсутствуют ссылочные типы (а следовательно и динамическое распределение памяти) и обработка исключений.

Многозадачность, в ее полном варианте, имеет очень сложную семантику исполнения. Но при использовании Ravenscar-профиля она все же подлежит формальному анализу. Ravenscar вошел в версию SPARK 2005 и его планируется добавить в следующую версию SPARK 2014 (к моменту перевода брошуры уже добавлен).

Вот список некоторых ограничений, вводимых SPARK 2014:

- Все выражения (в том числе вызовы функций) не производят побочных эффектов. Хотя функции в Ада 2012 могут иметь параметры с режимом in out и out, в SPARK это запрещено. Функции не могут изменять глобальные переменные. Эти ограничения помогают гарантировать, что компилятор волен выбирать любой порядок вычисления выражений и подчеркивают различие между процедурами, чья задача изменять состояние системы, и функциями, которые лишь анализируют это состояние.

- Совмещение имен (aliasing) запрещается. Например, нельзя передавать в процедуру глобальный объект при помощи out или in out параметр, если она обращается к нему напрямую. Это ограничение делает результат работы более прозрачным и позволяет убедиться, что компилятор волен выбрать любой способ передачи параметра (по значению или по ссылке).

- Инструкция goto запрещена. Это ограничение облегчает статический анализ.

- Использование контролируемых типов запрещено. Контролируемые типы приводят к неявным вызовам подпрограмм, генерируемых компилятором. Отсутствие исходного кода для этих конструкций затрудняет использование формальных методов.

В дополнение к этим ограничениям, SPARK предписывает более строгую политику инициализации, чем Ада. Объект, передаваемый через in или in out параметр, должен быть полностью инициализирован до вызова процедуры, а out параметр — до возвращения из нее.

Несмотря на эти ограничения, подмножество языка, поддерживаемое SPARK, все еще довольно велико. Оно включает типы с дискриминантами (но без ссылочных дискриминантов), теговые типы и диспетчеризацию, типы с динамическими границами, отрезки массивов и конкатенацию, статические предикаты, условные и кванторные выражения, функции-выражения, настраиваемые модули, дочерние модули и субмодули. Рекурсия допускается, а стандартная библиотека контейнеров может быть использована для создания сложных структур данных в условиях отсутствия ссылочных типов и динамического распределения памяти. SPARK также предлагает средства взаимодействия с внешним окружением при помощи аспектов, касающихся «изменчивых» (volatile) переменных (т. е. переменных, подверженных асинхронному чтению и записи).

В критических областях, где использование таких средств, как динамическое распределение памяти нежелательно, ранние версии языка SPARK доказали свою исключительную полезность. Теперь же SPARK 2014 существенно расширил набор разрешенных возможностей языка.

Формальные методы анализа

В этой главе мы мы коротко подытожим некоторые аспекты механизма формального анализа, используемого инструментарием SPARK.

Во первых, есть две формы потокового анализа:

- Потоковый анализ зависимостей данных учитывает инициализацию переменных и зависимости между данными внутри подпрограмм.

- Потоковый анализ потоковых зависимостей учитывает взаимосвязи результатов подпрограмм и их входных данных.

Потоковый анализ не требует от пользователя больших усилий, чем указания аспектов глобальных переменных и аспектов зависимостей, и, разумеется, учета правил языка SPARK. Добавления этих аспектов позволяет провести более подробный потоковый анализ и обнаружить больше ошибок на ранней стадии.

Важной возможностью потокового анализа является обнаружение неинициализированных переменных. Чтобы воспользоваться этим, необходимо избегать задавать «мусорные» начальные значения по умолчанию, просто «на всякий случай», как мы уже оговаривали это в главе «Безопасный запуск», поскольку это затруднит нахождение ошибок потоковым анализом.

Далее, существуют формальные процессы верификации, касающиеся доказательств:

- Формальная верификация свойств надежности (т. е. гарантия отсутствия возбуждения предопределенных исключений);

- Формальная верификация функциональных свойств, основанных на контрактах, таких как пред-условия и пост-условия.

В случае с функциональными свойствами, которые кроме пред- и пост-условий включают в себя инварианты циклов и утверждения, касающиеся типов, анализатор генерирует предположения, которые необходимо доказать для гарантирования корректности программы. Эти предположения известны, как условия верификации (verification conditions, VC). А доказательство их называют исполнением условий верификации. За последние годы произошел значительный прогресс в области автоматического доказательства теорем, благодаря чему GNATprove способен автоматически исполнять множество условий верификации. На момент написания этого текста используются технологии Alt-Ergo и CVC4, но можно использовать и другие системы доказательств теорем.

Важно отметить, что даже в отсутствии пред- и пост-условий анализатор способен генерировать предположения, соответствующие проверкам времени исполнения языка, таким как проверка диапазона. Как мы демонстрировали в главе «Безопасные типы данных», подобные проверки автоматически вставляются, чтобы гарантировать, что переменная не получит значений вне диапазона значений согласно ее объявлению. Аналогичные проверки контролируют попытки чтения/записи элементов за границами массива. Доказательство этих предположений демонстрирует, что условия не нарушаются и программа не содержит ошибок, приводящих к возбуждению исключений в момент исполнения.

Заметим, что использование доказательств не является обязательным. SPARK и соответствующий инструментарий можно использовать на разных уровнях. Для некоторых приложений достаточно использовать потоковый анализ. Но для других может быть экономически целесообразно также провести и доказательство корректности. На самом деле, различные уровни анализа могут быть использованы для различных частей программы. Этого можно добиться, используя различные варианты аспекта SPARK_Mode.

Гибридная верификация

Проведение формальной верификации для всего кода программы может быть нецелесообразно по следующим причинам:

- Часть программы может использовать все возможности Ады (или вообще может быть написана на другом языке, например C), и, следовательно, не поддается формальному анализу. Например, спецификация пакета может иметь аспект SPARK_Mode, а тело пакета — нет. В этом случае информация о контрактах из спецификации пакета может быть использована инструментарием формального анализа, хотя анализ самого тела пакета будет невозможен. Для не-SPARK модулей необходимо использовать традиционные методы тестирования.

- Даже если при написании компонента используется SPARK подмножество языка, не всегда возможно выразить требуемые свойства формально или доказать их с учетом текущих возможностей применяемого инструментария. Аналогично, применение тестирования необходимо для демонстрации заданных свойств.

Следующие инструменты для поддержки такого рода «гибридной верификации» входят в состав GNAT технологии.

- Порождающая верификация. GNATprove может быть использован для анализа Ада модулей вне зависимости от режима SPARK, чтобы определить неявные зависимости данных. Этот подход, который ранее мы назвали «порождающая верификация», позволяет применить формальные методы при для уже существующей кодовой базы.

- Результаты GNATprove. GNATprove может отобразить свойства подпрограммы, которые он не может установить, что означает, например, возможность появления ошибок во время исполнения. Это может помочь пользователю в написании тестов, либо указать, где необходим дальнейший анализ кода.

- Опции компилятора. Некоторые из ключей компилятора позволяют получить дополнительные проверки времени исполнения для таких ошибок, как пересекающиеся параметры или недействительные скалярные объекты, в модулях, для которых невозможен формальный анализ.

- Инструмент GNATtest. При помощи аспектов (или директив компилятору), специфичных для GNAT, можно определить для данной подпрограммы «формальные тестовые случаи». Это совокупность требуемых условий на входе в подпрограмму и ожидаемых условий при выходе из нее. Инструмент GNATtest использует эту информацию для автоматизации построения набора тестов.

Примеры

В качестве примера, рассмотрим версию стека с указанием потоковых зависимостей (аспект Depends) без использования пред- и пост-условий:

package Stacks

with Spark_Mode

is

type Stack is private;

function Is_Empty(S: Stack) return Boolean;

function Is_Full(S: Stack) return Boolean;

procedure Clear(S: out Stack)

with Depends => (S => null);

procedure Push(S: in out Stack; X: in Float)

with Depends => (S => (S, X));

procedure Pop(S: in out Stack; X: out Float)

with Depends => (S => S,

X => S);

private

Max: constant := 100;

type Top_Range is range 0 .. Max;

subtype Index_Range is Top_Range range 1 .. Max;

type Vector is array (Index_Range) of Float;

type Stack is record

A: Vector;

Top: Top_Range;

end record;

end Stacks;

Мы добавили функции Is_Full и Is_Empty, которые просто считывают состояние стека. Они не имеют аспектов.

Для остальных подпрограмм мы добавили аспекты Depends. Они позволяют указать, от каких аргументов зависит данный результат. Например, для Push указано (S => (S, X)), что означает, что конечное значение S зависит от начального значения S и начального значения X, что, в данном примере, можно вывести из режимов параметров. Но избыточность — это один из ключей достижения надежности. Если аспекты и режимы параметров противоречат друг другу, то это будет обнаружено автоматически при анализе, что, возможно, позволит найти ошибку в спецификации.

Объявления в приватной части были изменены, чтобы дать имена всем используемым подтипам, хотя это и не является обязательным в SPARK 2014.

На этом уровне не нужно вносить каких-либо изменений в тело пакета, поскольку контракты не требуются. Это подчеркивает тот факт, что SPARK касается в основном улучшения качества описания интерфейса.

Отличия появились также в том, что мы не присвоили начальное значение компоненте Top, а взамен требуем явного вызова Clear. При анализе клиентского SPARK-кода с помощью GNATprove будет проведен потоковый анализ, гарантирующий, что нет вызова процедур Push или Pop до вызова процедуры Clear. Этот анализ выполняется без исполнения программы. Если GNATprove не может доказать это, то в программе возможна ошибка. С другой стороны, если будет обнаружен вызов Push или Pop перед Clear, то это означает, что ошибка присутствует наверняка.

В таком коротком обзоре, как этот, невозможно привести какой-либо сложный пример анализа. Но мы приведем тривиальный пример, чтобы продемонстрировать идею. Следующий код:

procedure Exchange(X,Y: in out Float)

with Depends => (X => Y, Y => X),

Post => (X = Y'Old and Y = X'Old);

демонстрирует спецификацию процедуры, предназначенной для обмена значений двух параметров. Тело может выглядеть так:

procedure Exchange(X,Y: in out Float) is

T: Float;

begin

T := X; X := Y; Y := T;

end Exchange;

При анализе GNATprove создает условия верификации, выполнение которых необходимо доказать. В данном примере доказательство тривиально и выполняется автоматически. (Читатель может заметить, что доказательство сводится к проверке условия (x=x and y=y), которое, очевидно, истинно). В более сложных ситуациях GNATprove может не справиться с доказательством, тогда пользователь может предложить промежуточные утверждения, либо воспользоваться другим инструментарием для дальнейшего анализа.

Сертификация

Как было продемонстрировано в предыдущих главах, Ада - это превосходный язык для написания надежного ПО. Ада позволяет программисту обнаруживать ошибки на ранних стадиях процесса разработки. Еще больше ошибок можно выявить, используя SPARK даже без применения процедуры тестирования. Тестирование остается обязательным этапом разработки, несмотря на то, что это сложный и чреватый ошибками процесс.

В областях, где действуют наивысшие требования к безопасности и надежности, недостаточно иметь правильно работающую программу. Необходимо еще доказать, что она является таковой. Этот процесс доказательства называется сертификацией и выполняется согласно процедурам соответствующего органа сертификации. Примерами таких органов на территории США являются FAA в области безопасности и NSA в области надежности. SPARK обладает огромной ценностью в процессе разработки программ, подлежащих сертификации.

Может возникнуть впечатление, что использование SPARK увеличивает стоимость разработки. Однако, исследования систем, переданных в NSA, демонстрируют, что использование SPARK делает процесс разработки более дешевым по сравнению с обычными методами разработки. Несмотря на то, что необходимо потратить некоторые усилия на формулирование контрактов, это, в итоге, окупается за счет сокращения затрат на тестирование и исправление ошибок.

Дальнейший процесс

На момент написания этого текста две значительные разработки еще не завершены. Первая касается поддержки профиля Ravenscar в SPARK многозадачности. Вторая — это возможность указать уровни целостности различных компонент программы, которая позволит гарантировать, что поток информации удовлетворяет требованиям указанных уровней безопасности и надежности.

Узнать текущее состояние дел и получить всестороннюю документацию SPARK 2014 можно на сайте www.spark-2014.org/.

Footnotes

Заключение

Хочется надеяться, что эта брошюра была Вам интересна. Мы коснулись различных аспектов написания надежного ПО и надеемся, что смогли продемонстрировать особое положение языка Ада в этом вопросе. Напоследок мы коснемся некоторых моментов относительно разработки языков программирования.

Баланс между программным обеспечением и аппаратной частью сам по себе вызывает интерес. Аппаратные средства за последние пол-столетия развивались ошеломляющим темпом. Они сегодня не имеют ничего общего с тем, что было в 1960-х гг. По сравнению с аппаратными средствами, ПО тоже развивалось, но совсем чуть-чуть. Большинство языков программирования сейчас имеют лишь незначительные отличия от тех языков, что были в 1960-х. Я подозреваю, что основная причина этого заключается в том, что мы очень мало знаем о ПО, хотя считаем, что знаем о нем очень много. Человечество, вложив колоссальные средства в плохо написанное ПО, вдруг обнаружило, что никуда не может двинуться с ним дальше. В то же время новая аппаратура создается с такой скоростью, что это неизбежно приводит к ее замене. Несомненно, что любой может легко научиться, как написать небольшую программку, но чтобы создать хоть какую-нибудь аппаратуру требуется овладеть огромным объемом знаний.

Существуют две основные ветви развития языков. Одна берет начало от Algol 60 и CPL. Производные от этих языков часто упоминаются в этом буклете. Другая ветвь, охватывающая Fortran, COBOL и PL/I, также еще жива, хотя и весьма изолирована.

Algol 60 можно считать самым значительным шагом в развитии. (Когда-то существовал также его менее знаменитый предшественник Algol 58, от которого произошел язык Jovial, использовавшийся в военных сферах США.) Algol дал ощущение того, что написание ПО - это больше чем просто кодинг.

При создании Algol было сделано два больших шага вперед. Во первых, появилось понимание того, что присваивание не есть равенство. Это привело к появлению обозначения := для операции присваивания. Для обозначения различных управляющих структур стали использовать английские слова, в результате отпала необходимость в многочисленных инструкциях goto и метках, которые так затрудняли чтение программы на Fortran и autocode. На втором моменте стоит остановиться более подробно.

Сначала рассмотрим следующие две инструкции в Algol 60:

if X > 0 then

Action(...);

Otherstuff(...);

Суть в том, что если X больше нуля, то вызывается процедура Action. Независимо от этого, мы далее вызываем Otherstuff. Т.е. действие условия здесь распространяется только на первую инструкцию после then. Если нам необходимо несколько инструкций, например, вызвать две процедуры This и That, то мы должны объединить их в составную инструкцию следующим образом:

if X > 0 then

begin

This(...);

That(...);

end;

Otherstuff(...);

Здесь возникает опасность сделать две ошибки. Во первых, мы можем забыть добавить begin и end. Результат выйдет без ошибок, но процедура That будет вызываться в любом случае. Будет еще хуже, если мы нечаянно добавим лишнюю точку с запятой. Наверное, Algol 60 был первым языком, где использовалась точка с запятой как разделитель инструкций. Итак, мы получим:

if X > 0 then ;

begin

This(...);

That(...);

end;

Otherstuff(...);

К несчастью, в Algol 60 эта запись означает неявную пустую инструкцию после then. В результате, условие не будет влиять на вызовы подпрограмм This и That. Аналогичные проблемы в Algol 60 есть и для циклов.

Разработчики Algol 68 осознали эту проблему и ввели скобочную запись условной инструкции, т. е.:

if X > 0 then

This(...);

That(...);

fi;

Otherstuff(...);

Аналогичная запись появилась для циклов, где слову do соответствует od, а для case есть esac. Это полностью решает проблему. Теперь совершенно очевидно, что условная инструкция захватит оба вызова подпрограмм. Появление лишней точки с запятой после then приведет к синтаксической ошибке, которая легко будет обнаружена компилятором. Конечно, появление такой записи, как fi, od и esac выглядит причудливо, что может помешать серьезно отнестись к решаемой проблеме.

По какой-то причине разработчики языка Pascal проигнорировали этот здравый подход и оставили уязвимую запись инструкций из Algol 60. Они исправили свою ошибку гораздо позже, уже при проектировании Modula 2. К тому моменту Ада уже давно существовала.

Вероятно, в языке Ада впервые появилась удачная форма структурных инструкций, не использовавшая причудливую запись. На языке Ада мы бы написали:

if X > 0 then

This(...);

That(...);

end if;

Otherstuff(...);

Позже многие языки переняли такую безопасную форму записи. К таковым относится даже макро-язык для Microsoft Word for DOS и Visual Basic в составе Word for Windows.

Еще одним значимым языком можно считать CPL. Он был разработан в 1962г. и использовался в двух новых вычислительных машинах в университетах Кембриджа и Лондона.

CPL, (как и Algol 60) использовал := для обозначения присваивания и = для сравнения. Вот небольшой фрагмент кода на CPL:

§ let t, s, n = 1, 0, 1

let x be real

Read[x]

t, s, n := tx/n, s + t, n + 1

repeat until t<<1

Write[s] §

Интересная особенность CPL заключается в использовании = (вместо :=) при задании начальных значений, ввиду того, что при этом не происходит изменения значений. В CPL был ряд интересных решений, например, параллельное присваивание и обработка списков. Но CPL остался лишь академической игрушкой и не был реализован.

Для группировки инструкций язык CPL использовал запись, аналогичную принятой в Algol 60. Например

if X > 0 then do

§ This(...)

That(...) §⃒

Otherstuff(...);

Для этого использовались странные символы параграфа и параграфа перечеркнутого вертикальной чертой.

Хотя сам язык CPL никогда не был реализован, в Кембридже изобрели его упрощенный вариант BCPL (Basic CPL). В отличии от имеющего строгую типизацию CPL, BCPL вообще не имел типов, а массивы были реализованы с помощью адресной арифметики. Так BCPL положил начало проблеме переполнения буфера, от которой мы страдаем по сей день.

BCPL преобразился в B, а затем в C, C++ и т. д. В BCPL использовалось обозначение := для операции присваивания, но по пути кто-то забыл, в чем смысл, и C остался с обозначением =. Поскольку знак = оказался занят, для операции сравнения пришлось ввести обозначение ==, а вместе с этим получить букет проблем, о котором мы писали в главе «Безопасный синтаксис».

Язык C унаследовал принцип группировки инструкций от CPL, но заменил его странные символы на фигурные скобки. То есть в C мы напишем

if (x > 0)

{

this(...);

that(...);

};

otherstuff(...);

Что же, в C от CPL практически ничего не осталось, ну разве что скобочки для группировки инструкций.

В заключение отметим, что использование знака равенства для обозначения присваивания однозначно осуждал Кристофер Страчи, один из авторов CPL. Много лет назад, на лекциях NATO, он сказал: «То, как люди учатся программировать, отвратительно. Они снова и снова учатся каламбурить. Они используют операции сдвига вместо умножения, запутывают код, используя битовые маски и числовые литералы, и вообще говорят одно, когда имеют в виду что-то совсем другое. Я думаю у нас не будет инженерного подхода к разработке ПО до тех пор, пока у нас не закрепятся профессиональные стандарты о том, как писать программы. А добиться этого можно лишь, начиная обучение программированию с того, как писать программы должным образом. Я убежден, что, в первую очередь, необходимо начать говорить именно то, что вы хотите сказать, а не что-то другое.»

Таков будет наш вывод. Мы должны научиться выражать, то что мы думаем. И язык Ада позволяет нам выразить это ясно, и в этом, в конечном счете, его сила.

Footnotes

Список литературы

[1] RTCA DO-178B / EUROCAE ED-12B. Software Considerations in Airborne Systems and Equipment Certification (December 1992).

[2] RTCA DO-178C / EUROCAE ED-12C. Software Considerations in Airborne Systems and Equipment Certification (December 2011).

[3] MISRA-C:2004, Guidelines for the use of the C language in critical systems (October 2004).

[4] Barbara Liskov and Jeannette Wing. “A behavioral notion of subtyping”, ACM Transactions on Programming Languages and Systems (TOPLAS), Vol. 16, Issue 6 (November 1994), pp 1811-1841.

[5] RTCA DO-332 / EUROCAE ED-217. Object-Oriented Technology and Related Techniques Supplement to DO-178C and DO-278A (December 2011).

[6] AdaCore. High-Integrity Object-Oriented Programming Release 1.3 (July 2011), www.open-do.org/hi-oo-ada in Ada,

[7] Cyrille Comar and Pat Rogers. On Dynamic Plug-in Loading with Ada 95 and Ada 2005. AdaCore (2005). www.sigada.org/ada_letters/jun2005/Dynamic _plugin_loading_with-Pat Rogers.pdf

[8] ISO/IEC TR 24718:2004. Guide for the use of the Ada Ravenscar profile in high integrity systems (2004).

[9] Alan Burns and Andy Wellings. Concurrent and Real-Time programming in Ada 2005. Cambridge University Press (2006).

[10] Janet Barnes, Rod Chapman, Randy Johnson, James Widmaier, David Cooper and Bill Everett. Engineering the Tokeneer Enclave Protection Software. Published in ISSSE 06, the proceedings of the 1st IEEE International Symposium on Secure Software Engineering. IEEE (March 2006). www.sparkada.com.

Footnotes

Index

About learn.adacore.com

Learn.adacore.com is an interactive learning platform designed to teach the Ada and SPARK programming languages. With courses featuring hands-on labs and easy to understand code snippets, you will have the opportunity to see, understand and experiment with the language capabilities.

About Ada/SPARK

The Ada programming language was designed from its inception to be used in applications where safety and security are of the utmost importance. Its feature set and programming paradigms, by design, allow software developers to develop applications more effectively and efficiently. It encourages a “think first, code later” principle which produces more readable, reliable, and maintainable software.

The SPARK programming language is a formally verifiable subset of the Ada language which allows developers to mathematically prove program correctness through static means. This is accomplished by exploiting the strengths of the Ada syntax while eliminating the features of the language that introduce ambiguity and non-deterministic behavior. The language put together with a verification toolset and a design methodology ensures the development and deployment of low-defect software for high reliability applications.

About AdaCore

Founded in 1994, AdaCore is the leading provider of commercial and open-source software solutions for Ada, a state-of-the-art programming language designed for large, long-lived applications where safety, security, and reliability are critical. AdaCore is committed to being an active member of the software development community providing the GNAT Ada compiler and SPARK formal methods technologies as open-source projects to the world to advocate their use in the future of safe and reliable computing. Visit the AdaCore website#1 for more information.

Footnotes

#1

https://www.adacore.com

Bug Free Coding with SPARK Ada

Release 2022-08

Aug 22, 2022

Copyright © 2018 – 2022, AdaCore

This book is published under a CC BY-SA license, which means that you can copy, redistribute, remix, transform, and build upon the content for any purpose, even commercially, as long as you give appropriate credit, provide a link to the license, and indicate if changes were made. If you remix, transform, or build upon the material, you must distribute your contributions under the same license as the original. You can find license details on this page#1

Workshop project: Learn to write maintainable bug-free code with SPARK Ada.

This document was written by Robert Tice.

Contents:

- Let's Build a Stack

- Background

- Input Format

- Constraints

- Output Format

- Sample Input

- Sample Output

Footnotes

#1

http://creativecommons.org/licenses/by-sa/4.0

Let's Build a Stack

In this lab we will build a stack data structure and use the SPARK provers to find the errors in the below implementation.

Background

So, what is a stack?

A stack is like a pile of dishes...

1. The pile starts out empty.

2. You add ( push ) a new plate ( data ) to the stack by placing it on the top of the pile.

3. To get plates ( data ) out, you take the one off the top of the pile ( pop ).

4. Out stack has a maximum height ( size ) of 9 dishes

Pushing items onto the stack

Here's what should happen if we pushed the string MLH onto the stack.

The list starts out empty. Each time we push a character onto the stack, Last increments by 1.

Popping items from the stack

Here's what should happen if we popped 2 characters off our stack & then clear it.

Note that pop and clear don't unset the Storage array's elements, they just change the value of Last.

Input Format

N inputs will be read from stdin/console as inputs, C to the stack.

Constraints

1 <= N <= 1000

C is any character. Characters d and p will be special characters corresponding to the below commands:

p => Pops a character off the stack

d => Prints the current characters in the stack

Output Format

If the stack currently has the characters "M", "L", and "H" then the program should print the stack like this:

[M, L, H]

Sample Input

M L H d p d p d p d

Sample Output

[M, L, H] [M, L] [M] []

stack.ads

1package Stack with SPARK_Mode => On is

2

3   procedure Push (V : Character)

4     with Pre  => not Full,

5          Post => Size = Size'Old + 1;

6

7   procedure Pop (V : out Character)

8     with Pre  => not Empty,

9          Post => Size = Size'Old - 1;

10

11   procedure Clear

12     with Post => Size = 0;

13

14   function Top return Character

15     with Post => Top'Result = Tab(Last);

16

17   Max_Size : constant := 9;

18   --  The stack size.

19

20   Last : Integer range 0 .. Max_Size := 0;

21   --  Indicates the top of the stack. When 0 the stack is empty.

22

23   Tab  : array (1 .. Max_Size) of Character;

24   --  The stack. We push and pop pointers to Values.

25

26   function Full return Boolean is (Last = Max_Size);

27

28   function Empty return Boolean is (Last < 1);

29

30   function Size return Integer is (Last);

31

32end Stack;

stack.adb

1package body Stack with SPARK_Mode => On is

2

3   -----------

4   -- Clear --

5   -----------

6

7   procedure Clear

8   is

9   begin

10      Last := Tab'First;

11   end Clear;

12

13   ----------

14   -- Push --

15   ----------

16

17   procedure Push (V : Character)

18   is

19   begin

20      Tab (Last) := V;

21   end Push;

22

23   ---------

24   -- Pop --

25   ---------

26

27   procedure Pop (V : out Character)

28   is

29   begin

30      Last := Last - 1;

31      V := Tab (Last);

32   end Pop;

33

34   ---------

35   -- Top --

36   ---------

37

38   function Top return Character

39   is

40   begin

41      return Tab (1);

42   end Top;

43

44end Stack;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Stack;            use Stack;

4

5procedure Main with SPARK_Mode => Off

6is

7

8   -----------

9   -- Debug --

10   -----------

11

12   procedure Debug

13   is

14   begin

15

16      if not Stack.Empty then

17

18         Put ("[");

19         for I in Stack.Tab'First .. Stack.Size - 1 loop

20            Put (Stack.Tab (I) & ", ");

21         end loop;

22         Put_Line (Stack.Tab (Stack.Size) & "]");

23      else

24         Put_Line ("[]");

25      end if;

26

27   end Debug;

28

29   S : Character;

30

31begin

32

33   ----------

34   -- Main --

35   ----------

36

37   for Arg in 1 .. Argument_Count loop

38      if Argument (Arg)'Length /= 1 then

39         Put_Line (Argument (Arg) & " is an invalid input to the stack.");

40      else

41         S := Argument (Arg)(Argument (Arg)'First);

42

43         if S = 'd' then

44            Debug;

45         elsif S = 'p' then

46            if not Stack.Empty then

47               Stack.Pop (S);

48            else

49               Put_Line ("Nothing to Pop, Stack is empty!");

50            end if;

51         else

52            if not Stack.Full then

53               Stack.Push (S);

54            else

55               Put_Line ("Could not push '" & S & "', Stack is full!");

56            end if;

57         end if;

58      end if;

59

60   end loop;

61

62end Main;

Footnotes

Introduction to Ada: Laboratories

Release 2022-08

Aug 22, 2022

Copyright © 2019 – 2022, AdaCore

This book is published under a CC BY-SA license, which means that you can copy, redistribute, remix, transform, and build upon the content for any purpose, even commercially, as long as you give appropriate credit, provide a link to the license, and indicate if changes were made. If you remix, transform, or build upon the material, you must distribute your contributions under the same license as the original. You can find license details on this page#1

These labs contain exercises for the Introduction to Ada course.

This document was written by Gustavo A. Hoffmann and reviewed by Michael Frank.

Contents:

- Imperative Language

- Hello World

- Greetings

- Positive Or Negative

- Numbers

- Subprograms

- Subtract procedure

- Subtract function

- Equality function

- States

- States #2

- States #3

- States #4

- Modular Programming

- Months

- Operations

- Strongly Typed Language

- Colors

- Integers

- Temperatures

- Records

- Directions

- Colors

- Inventory

- Arrays

- Constrained Array

- Colors: Lookup-Table

- Unconstrained Array

- Product info

- String_10

- List of Names

- More About Types

- Aggregate Initialization

- Versioning

- Simple todo list

- Price list

- Privacy

- Directions

- Limited Strings

- Bonus exercise

- Colors

- List of Names

- Price List

- Generics

- Display Array

- Average of Array of Float

- Average of Array of Any Type

- Generic list

- Exceptions

- Uninitialized Value

- Numerical Exception

- Re-raising Exceptions

- Tasking

- Display Service

- Event Manager

- Generic Protected Queue

- Design by contracts

- Price Range

- Pythagorean Theorem: Predicate

- Pythagorean Theorem: Precondition

- Pythagorean Theorem: Postcondition

- Pythagorean Theorem: Type Invariant

- Primary Color

- Object Oriented Programming

- Simple type extension

- Online Store

- Standard Library: Containers

- Simple todo list

- List of unique integers

- Standard Library: Dates & Times

- Holocene calendar

- List of events

- Standard Library: Strings

- Concatenation

- List of events

- Standard Library: Numerics

- Decibel Factor

- Root-Mean-Square

- Rotation

- Solutions

- Imperative Language

- Hello World

- Greetings

- Positive Or Negative

- Numbers

- Subprograms

- Subtract Procedure

- Subtract Function

- Equality function

- States

- States #2

- States #3

- States #4

- Modular Programming

- Months

- Operations

- Strongly typed language

- Colors

- Integers

- Temperatures

- Records

- Directions

- Colors

- Inventory

- Arrays

- Constrained Array

- Colors: Lookup-Table

- Unconstrained Array

- Product info

- String_10

- List of Names

- More About Types

- Aggregate Initialization

- Versioning

- Simple todo list

- Price list

- Privacy

- Directions

- Limited Strings

- Generics

- Display Array

- Average of Array of Float

- Average of Array of Any Type

- Generic list

- Exceptions

- Uninitialized Value

- Numerical Exception

- Re-raising Exceptions

- Tasking

- Display Service

- Event Manager

- Generic Protected Queue

- Design by contracts

- Price Range

- Pythagorean Theorem: Predicate

- Pythagorean Theorem: Precondition

- Pythagorean Theorem: Postcondition

- Pythagorean Theorem: Type Invariant

- Primary Colors

- Object-oriented programming

- Simple type extension

- Online Store

- Standard library: Containers

- Simple todo list

- List of unique integers

- Standard library: Dates & Times

- Holocene calendar

- List of events

- Standard library: Strings

- Concatenation

- List of events

- Standard library: Numerics

- Decibel Factor

- Root-Mean-Square

- Rotation

Footnotes

#1

http://creativecommons.org/licenses/by-sa/4.0

Arrays

Constrained Array

Goal: declare a constrained array and implement operations on it.

Steps:

1. Implement the Constrained_Arrays package.

1. Declare the range type My_Index.

2. Declare the array type My_Array.

3. Declare and implement the Init function.

4. Declare and implement the Double procedure.

5. Declare and implement the First_Elem function.

6. Declare and implement the Last_Elem function.

7. Declare and implement the Length function.

8. Declare the object A of My_Array type.

Requirements:

1. Range type My_Index has a range from 1 to 10.

2. My_Array is a constrained array of Integer type.

1. It must make use of the My_Index type.

2. It is therefore limited to 10 elements.

3. Function Init returns an array where each element is initialized with the corresponding index.

4. Procedure Double doubles the value of each element of an array.

5. Function First_Elem returns the first element of the array.

6. Function Last_Elem returns the last element of the array.

7. Function Length returns the length of the array.

8. Object A of My_Array type is initialized with:

1. the values 1 and 2 for the first two elements, and

2. 42 for all other elements.

constrained_arrays.ads

1package Constrained_Arrays is

2

3   --  Complete the type and subprogram declarations:

4   --

5   --  type My_Index is [...]

6   --

7   --  type My_Array is [...]

8   --

9   --  function Init ...

10   --

11   --  procedure Double ...

12   --

13   --  function First_Elem ...

14   --

15   --  function Last_Elem ...

16   --

17   --  function Length ...

18   --

19   --  A : ...

20

21end Constrained_Arrays;

constrained_arrays.adb

1package body Constrained_Arrays is

2

3   --  Create the implementation of the subprograms!

4   --

5

6end Constrained_Arrays;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Constrained_Arrays; use Constrained_Arrays;

5

6procedure Main is

7   type Test_Case_Index is

8     (Range_Chk,

9      Array_Range_Chk,

10      A_Obj_Chk,

11      Init_Chk,

12      Double_Chk,

13      First_Elem_Chk,

14      Last_Elem_Chk,

15      Length_Chk);

16

17   procedure Check (TC : Test_Case_Index) is

18      AA : My_Array;

19

20      procedure Display (A : My_Array) is

21      begin

22         for I in A'Range loop

23            Put_Line (Integer'Image (A (I)));

24         end loop;

25      end Display;

26

27      procedure Local_Init (A : in out My_Array) is

28      begin

29         A := (100, 90, 80, 10, 20, 30, 40, 60, 50, 70);

30      end Local_Init;

31   begin

32      case TC is

33      when Range_Chk =>

34         for I in My_Index loop

35            Put_Line (My_Index'Image (I));

36         end loop;

37      when Array_Range_Chk =>

38         for I in My_Array'Range loop

39            Put_Line (My_Index'Image (I));

40         end loop;

41      when A_Obj_Chk =>

42         Display (A);

43      when Init_Chk =>

44         AA := Init;

45         Display (AA);

46      when Double_Chk =>

47         Local_Init (AA);

48         Double (AA);

49         Display (AA);

50      when First_Elem_Chk =>

51         Local_Init (AA);

52         Put_Line (Integer'Image (First_Elem (AA)));

53      when Last_Elem_Chk =>

54         Local_Init (AA);

55         Put_Line (Integer'Image (Last_Elem (AA)));

56      when Length_Chk =>

57         Put_Line (Integer'Image (Length (AA)));

58      end case;

59   end Check;

60

61begin

62   if Argument_Count < 1 then

63      Put_Line ("ERROR: missing arguments! Exiting...");

64      return;

65   elsif Argument_Count > 1 then

66      Put_Line ("Ignoring additional arguments...");

67   end if;

68

69   Check (Test_Case_Index'Value (Argument (1)));

70end Main;

Colors: Lookup-Table

Goal: rewrite a package to represent HTML colors in RGB format using a lookup table.

Steps:

1. Implement the Color_Types package.

1. Declare the array type HTML_Color_RGB.

2. Declare the To_RGB_Lookup_Table object and initialize it.

3. Adapt the implementation of the To_RGB function.

Requirements:

1. Array type HTML_Color_RGB is used for the table.

2. The To_RGB_Lookup_Table object of HTML_Color_RGB type contains the lookup table.

- This table must be implemented as an array of constant values.

3. The implementation of the To_RGB function must use the To_RGB_Lookup_Table object.

Remarks:

1. This exercise is based on the HTML colors exercise from a previous lab (Records).

2. In the previous implementation, you could use a case statement to implement the To_RGB function. Here, you must rewrite the function using a look-up table.

1. The implementation of the To_RGB function below includes the case statement as commented-out code. You can use this as your starting point: you just need to copy it and convert the case statement to an array declaration.

1. Don't use a case statement to implement the To_RGB function. Instead, write code that accesses To_RGB_Lookup_Table to get the correct value.

3. The following table contains the HTML colors and the corresponding value in hexadecimal form for each color element:

Color

Red

Green

Blue

Salmon

#FA

#80

#72

Firebrick

#B2

#22

#22

Red

#FF

#00

#00

Darkred

#8B

#00

#00

Lime

#00

#FF

#00

Forestgreen

#22

#8B

#22

Green

#00

#80

#00

Darkgreen

#00

#64

#00

Blue

#00

#00

#FF

Mediumblue

#00

#00

#CD

Darkblue

#00

#00

#8B

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   subtype Int_Color is Integer range 0 .. 255;

17

18   type RGB is record

19      Red   : Int_Color;

20      Green : Int_Color;

21      Blue  : Int_Color;

22   end record;

23

24   function To_RGB (C : HTML_Color) return RGB;

25

26   function Image (C : RGB) return String;

27

28   --  Declare array type for lookup table here:

29   --

30   --  type HTML_Color_RGB is ...

31

32   --  Declare lookup table here:

33   --

34   --  To_RGB_Lookup_Table : ...

35

36end Color_Types;

color_types.adb

1with Ada.Integer_Text_IO;

2package body Color_Types is

3

4   function To_RGB (C : HTML_Color) return RGB is

5   begin

6      --  Implement To_RGB using To_RGB_Lookup_Table

7      return (0, 0, 0);

8

9      --  Use the code below from the previous version of the To_RGB

10      --  function to declare the To_RGB_Lookup_Table:

11      --

12      --  case C is

13      --     when Salmon      => return (16#FA#, 16#80#, 16#72#);

14      --     when Firebrick   => return (16#B2#, 16#22#, 16#22#);

15      --     when Red         => return (16#FF#, 16#00#, 16#00#);

16      --     when Darkred     => return (16#8B#, 16#00#, 16#00#);

17      --     when Lime        => return (16#00#, 16#FF#, 16#00#);

18      --     when Forestgreen => return (16#22#, 16#8B#, 16#22#);

19      --     when Green       => return (16#00#, 16#80#, 16#00#);

20      --     when Darkgreen   => return (16#00#, 16#64#, 16#00#);

21      --     when Blue        => return (16#00#, 16#00#, 16#FF#);

22      --     when Mediumblue  => return (16#00#, 16#00#, 16#CD#);

23      --     when Darkblue    => return (16#00#, 16#00#, 16#8B#);

24      --  end case;

25

26   end To_RGB;

27

28   function Image (C : RGB) return String is

29      subtype Str_Range is Integer range 1 .. 10;

30      SR : String (Str_Range);

31      SG : String (Str_Range);

32      SB : String (Str_Range);

33   begin

34      Ada.Integer_Text_IO.Put (To    => SR,

35                               Item  => C.Red,

36                               Base  => 16);

37      Ada.Integer_Text_IO.Put (To    => SG,

38                               Item  => C.Green,

39                               Base  => 16);

40      Ada.Integer_Text_IO.Put (To    => SB,

41                               Item  => C.Blue,

42                               Base  => 16);

43      return ("(Red => " & SR

44              & ", Green => " & SG

45              & ", Blue => "  & SB

46              &")");

47   end Image;

48

49end Color_Types;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Color_Types;          use Color_Types;

5

6procedure Main is

7   type Test_Case_Index is

8     (Color_Table_Chk,

9      HTML_Color_To_Integer_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12   begin

13      case TC is

14         when Color_Table_Chk =>

15            Put_Line ("Size of HTML_Color_RGB: "

16                      & Integer'Image (HTML_Color_RGB'Length));

17            Put_Line ("Firebrick: "

18                      & Image (To_RGB_Lookup_Table (Firebrick)));

19         when HTML_Color_To_Integer_Chk =>

20            for I in HTML_Color'Range loop

21               Put_Line (HTML_Color'Image (I) & " => "

22                         & Image (To_RGB (I)) & ".");

23            end loop;

24      end case;

25   end Check;

26

27begin

28   if Argument_Count < 1 then

29      Put_Line ("ERROR: missing arguments! Exiting...");

30      return;

31   elsif Argument_Count > 1 then

32      Put_Line ("Ignoring additional arguments...");

33   end if;

34

35   Check (Test_Case_Index'Value (Argument (1)));

36end Main;

Unconstrained Array

Goal: declare an unconstrained array and implement operations on it.

Steps:

1. Implement the Unconstrained_Arrays package.

1. Declare the My_Array type.

2. Declare and implement the Init procedure.

3. Declare and implement the Init function.

4. Declare and implement the Double procedure.

5. Declare and implement the Diff_Prev_Elem function.

Requirements:

1. My_Array is an unconstrained array (with a Positive range) of Integer elements.

2. Procedure Init initializes each element with the index starting with the last one.

- For example, for an array of 3 elements where the index of the first element is 1 (My_Array (1 .. 3)), the values of these elements after a call to Init must be (3, 2, 1).

3. Function Init returns an array based on the length L and start index I provided to the Init function.

1. I indicates the index of the first element of the array.

2. L indicates the length of the array.

3. Both I and L must be positive.

4. This is its declaration: function Init (I, L : Positive) return My_Array;.

5. You must initialize the elements of the array in the same manner as for the Init procedure described above.

4. Procedure Double doubles each element of an array.

5. Function Diff_Prev_Elem returns — for each element of an input array A — an array with the difference between an element of array A and the previous element.

1. For the first element, the difference must be zero.

2. For example:

- INPUT: (2, 5, 15)

- RETURN of Diff_Prev_Elem: (0, 3, 10), where

- 0 is the constant difference for the first element;

- 5 - 2 = 3 is the difference between the second and the first elements of the input array;

- 15 - 5 = 10 is the difference between the third and the second elements of the input array.

Remarks:

1. For an array A, you can retrieve the index of the last element with the attribute 'Last.

1. For example: Y : Positive := A'Last;

2. This can be useful during the implementation of procedure Init.

2. For the implementation of the Init function, you can call the Init procedure to initialize the elements. By doing this, you avoid code duplication.

3. Some hints about attributes:

1. You can use the range attribute (A'Range) to retrieve the range of an array A.

2. You can also use the range attribute in the declaration of another array (e.g.: B : My_Array (A'Range)).

3. Alternatively, you can use the A'First and A'Last attributes in an array declaration.

unconstrained_arrays.ads

1package Unconstrained_Arrays is

2

3   --  Complete the type and subprogram declarations:

4   --

5   --  type My_Array is ...;

6   --

7   --  procedure Init ...;

8

9   function Init (I, L : Positive) return My_Array;

10

11   --  procedure Double ...;

12   --

13   --  function Diff_Prev_Elem ...;

14

15end Unconstrained_Arrays;

unconstrained_arrays.adb

1package body Unconstrained_Arrays is

2

3   --  Implement the subprograms:

4   --

5

6   --  procedure Init is...

7

8   --  function Init (L : Positive) return My_Array is...

9

10   --  procedure Double ... is...

11

12   --  function Diff_Prev_Elem ... is...

13

14end Unconstrained_Arrays;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Unconstrained_Arrays; use Unconstrained_Arrays;

5

6procedure Main is

7   type Test_Case_Index is

8     (Init_Chk,

9      Init_Proc_Chk,

10      Double_Chk,

11      Diff_Prev_Chk,

12      Diff_Prev_Single_Chk);

13

14   procedure Check (TC : Test_Case_Index) is

15      AA : My_Array (1 .. 5);

16      AB : My_Array (5 .. 9);

17

18      procedure Display (A : My_Array) is

19      begin

20         for I in A'Range loop

21            Put_Line (Integer'Image (A (I)));

22         end loop;

23      end Display;

24

25      procedure Local_Init (A : in out My_Array) is

26      begin

27         A := (1, 2, 5, 10, -10);

28      end Local_Init;

29

30   begin

31      case TC is

32      when Init_Chk =>

33         AA := Init (AA'First, AA'Length);

34         AB := Init (AB'First, AB'Length);

35         Display (AA);

36         Display (AB);

37      when Init_Proc_Chk =>

38         Init (AA);

39         Init (AB);

40         Display (AA);

41         Display (AB);

42      when Double_Chk =>

43         Local_Init (AB);

44         Double (AB);

45         Display (AB);

46      when Diff_Prev_Chk =>

47         Local_Init (AB);

48         AB := Diff_Prev_Elem (AB);

49         Display (AB);

50      when Diff_Prev_Single_Chk =>

51         declare

52            A1 : My_Array (1 .. 1) := (1 => 42);

53         begin

54            A1 := Diff_Prev_Elem (A1);

55            Display (A1);

56         end;

57      end case;

58   end Check;

59

60begin

61   if Argument_Count < 1 then

62      Put_Line ("ERROR: missing arguments! Exiting...");

63      return;

64   elsif Argument_Count > 1 then

65      Put_Line ("Ignoring additional arguments...");

66   end if;

67

68   Check (Test_Case_Index'Value (Argument (1)));

69end Main;

Product info

Goal: create a system to keep track of quantities and prices of products.

Steps:

1. Implement the Product_Info_Pkg package.

1. Declare the array type Product_Infos.

2. Declare the array type Currency_Array.

3. Implement the Total procedure.

4. Implement the Total function returning an array of Currency_Array type.

5. Implement the Total function returning a single value of Currency type.

Requirements:

1. Quantity of an individual product is represented by the Quantity subtype.

2. Price of an individual product is represented by the Currency subtype.

3. Record type Product_Info deals with information for various products.

4. Array type Product_Infos is used to represent a list of products.

5. Array type Currency_Array is used to represent a list of total values of individual products (see more details below).

6. Procedure Total receives an input array of products.

1. It outputs an array with the total value of each product using the Currency_Array type.

2. The total value of an individual product is calculated by multiplying the quantity for this product by its price.

7. Function Total returns an array of Currency_Array type.

1. This function has the same purpose as the procedure Total.

2. The difference is that the function returns an array instead of providing this array as an output parameter.

8. The second function Total returns a single value of Currency type.

1. This function receives an array of products.

2. It returns a single value corresponding to the total value for all products in the system.

Remarks:

1. You can use Currency (Q) to convert from an element Q of Quantity type to the Currency type.

1. As you might remember, Ada requires an explicit conversion in calculations where variables of both integer and floating-point types are used.

2. In our case, the Quantity subtype is based on the Integer type and the Currency subtype is based on the Float type, so a conversion is necessary in calculations using those types.

product_info_pkg.ads

1package Product_Info_Pkg is

2

3   subtype Quantity is Natural;

4

5   subtype Currency is Float;

6

7   type Product_Info is record

8      Units : Quantity;

9      Price : Currency;

10   end record;

11

12   --  Complete the type declarations:

13   --

14   --  type Product_Infos is ...

15   --

16   --  type Currency_Array is ...

17

18   procedure Total (P   : Product_Infos;

19                    Tot : out Currency_Array);

20

21   function Total (P : Product_Infos) return Currency_Array;

22

23   function Total (P : Product_Infos) return Currency;

24

25end Product_Info_Pkg;

product_info_pkg.adb

1package body Product_Info_Pkg is

2

3   --  Complete the subprogram implementations:

4   --

5

6   --  procedure Total (P   : Product_Infos;

7   --                   Tot : out Currency_Array) is ...

8

9   --  function Total (P : Product_Infos) return Currency_Array is ...

10

11   --  function Total (P : Product_Infos) return Currency is ...

12

13end Product_Info_Pkg;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Product_Info_Pkg;   use Product_Info_Pkg;

5

6procedure Main is

7   package Currency_IO is new Ada.Text_IO.Float_IO (Currency);

8

9   type Test_Case_Index is

10     (Total_Func_Chk,

11      Total_Proc_Chk,

12      Total_Value_Chk);

13

14   procedure Check (TC : Test_Case_Index) is

15      subtype Test_Range is Positive range 1 .. 5;

16

17      P    : Product_Infos (Test_Range);

18      Tots : Currency_Array (Test_Range);

19      Tot  : Currency;

20

21      procedure Display (Tots : Currency_Array) is

22      begin

23         for I in Tots'Range loop

24            Currency_IO.Put (Tots (I));

25            New_Line;

26         end loop;

27      end Display;

28

29      procedure Local_Init (P : in out Product_Infos) is

30      begin

31         P := ((1,   0.5),

32               (2,  10.0),

33               (5,  40.0),

34               (10, 10.0),

35               (10, 20.0));

36      end Local_Init;

37

38   begin

39      Currency_IO.Default_Fore := 1;

40      Currency_IO.Default_Aft  := 2;

41      Currency_IO.Default_Exp  := 0;

42

43      case TC is

44      when Total_Func_Chk =>

45         Local_Init (P);

46         Tots := Total (P);

47         Display (Tots);

48      when Total_Proc_Chk =>

49         Local_Init (P);

50         Total (P, Tots);

51         Display (Tots);

52      when Total_Value_Chk =>

53         Local_Init (P);

54         Tot := Total (P);

55         Currency_IO.Put (Tot);

56         New_Line;

57      end case;

58   end Check;

59

60begin

61   if Argument_Count < 1 then

62      Put_Line ("ERROR: missing arguments! Exiting...");

63      return;

64   elsif Argument_Count > 1 then

65      Put_Line ("Ignoring additional arguments...");

66   end if;

67

68   Check (Test_Case_Index'Value (Argument (1)));

69end Main;

String_10

Goal: work with constrained string types.

Steps:

1. Implement the Strings_10 package.

1. Declare the String_10 type.

2. Implement the To_String_10 function.

Requirements:

1. The constrained string type String_10 is an array of ten characters.

2. Function To_String_10 returns constrained strings of String_10 type based on an input parameter of String type.

- For strings that are more than 10 characters, omit everything after the 11th character.

- For strings that are fewer than 10 characters, pad the string with ' ' characters until it is 10 characters.

Remarks:

1. Declaring String_10 as a subtype of String is the easiest way.

- You may declare it as a new type as well. However, this requires some adaptations in the Main test procedure.

2. You can use Integer'Min to calculate the minimum of two integer values.

strings_10.ads

1package Strings_10 is

2

3   --  Complete the type and subprogram declarations:

4   --

5

6   --  subtype String_10 is ...;

7

8   --  Using "type String_10 is..." is possible, too. However, it

9   --  requires a custom Put_Line procedure that is called in Main:

10   --  procedure Put_Line (S : String_10);

11

12   --  function To_String_10 ...;

13

14end Strings_10;

strings_10.adb

1package body Strings_10 is

2

3   --  Complete the subprogram declaration and implementation:

4   --

5   --  function To_String_10 ... is

6

7end Strings_10;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Strings_10;         use Strings_10;

5

6procedure Main is

7   type Test_Case_Index is

8     (String_10_Long_Chk,

9      String_10_Short_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      SL   : constant String := "And this is a long string just for testing...";

13      SS   : constant String := "Hey!";

14      S_10 : String_10;

15

16   begin

17      case TC is

18      when String_10_Long_Chk =>

19         S_10 := To_String_10 (SL);

20         Put_Line (String (S_10));

21      when String_10_Short_Chk =>

22         S_10 := (others => ' ');

23         S_10 := To_String_10 (SS);

24         Put_Line (String (S_10));

25      end case;

26   end Check;

27

28begin

29   if Argument_Count < 1 then

30      Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting...");

31      return;

32   elsif Argument_Count > 1 then

33      Ada.Text_IO.Put_Line ("Ignoring additional arguments...");

34   end if;

35

36   Check (Test_Case_Index'Value (Argument (1)));

37end Main;

List of Names

Goal: create a system for a list of names and ages.

Steps:

1. Implement the Names_Ages package.

1. Declare the People_Array array type.

2. Complete the declaration of the People record type with the People_A element of People_Array type.

3. Implement the Add procedure.

4. Implement the Reset procedure.

5. Implement the Get function.

6. Implement the Update procedure.

7. Implement the Display procedure.

Requirements:

1. Each person is represented by the Person type, which is a record containing the name and the age of that person.

2. People_Array is an unconstrained array of Person type with a positive range.

3. The Max_People constant is set to 10.

4. Record type People contains:

1. The People_A element of People_Array type.

2. This array must be constrained by the Max_People constant.

5. Procedure Add adds a person to the list.

1. By default, the age of this person is set to zero in this procedure.

6. Procedure Reset resets the list.

7. Function Get retrieves the age of a person from the list.

8. Procedure Update updates the age of a person in the list.

9. Procedure Display shows the complete list using the following format:

1. The first line must be LIST OF NAMES:. It is followed by the name and age of each person in the next lines.

2. For each person on the list, the procedure must display the information in the following format:

NAME: XXXX

AGE: YY

Remarks:

1. In the implementation of procedure Add, you may use an index to indicate the last valid position in the array — see Last_Valid in the code below.

2. In the implementation of procedure Display, you should use the Trim function from the Ada.Strings.Fixed package to format the person's name — for example: Trim (P.Name, Right).

3. You may need the Integer'Min (A, B) and the Integer'Max (A, B) functions to get the minimum and maximum values in a comparison between two integer values A and B.

4. Fixed-length strings can be initialized with whitespaces using the others syntax. For example: S : String_10 := (others => ' ');

5. You may implement additional subprograms to deal with other types declared in the Names_Ages package below, such as the Name_Type and the Person type.

1. For example, a function To_Name_Type to convert from String to Name_Type might be useful.

2. Take a moment to reflect on which additional subprograms could be useful as well.

names_ages.ads

1package Names_Ages is

2

3   Max_People : constant Positive := 10;

4

5   subtype Name_Type is String (1 .. 50);

6

7   type Age_Type is new Natural;

8

9   type Person is record

10      Name  : Name_Type;

11      Age   : Age_Type;

12   end record;

13

14   --  Add type declaration for People_Array record:

15   --

16   --  type People_Array is ...;

17

18   --  Replace type declaration for People record. You may use the

19   --  following template:

20   --

21   --  type People is record

22   --     People_A   : People_Array ...;

23   --     Last_Valid : Natural;

24   --  end record;

25   --

26   type People is null record;

27

28   procedure Reset (P : in out People);

29

30   procedure Add (P    : in out People;

31                  Name : String);

32

33   function Get (P    : People;

34                 Name : String) return Age_Type;

35

36   procedure Update (P    : in out People;

37                     Name : String;

38                     Age  : Age_Type);

39

40   procedure Display (P : People);

41

42end Names_Ages;

names_ages.adb

1with Ada.Text_IO;       use Ada.Text_IO;

2with Ada.Strings;       use Ada.Strings;

3with Ada.Strings.Fixed; use Ada.Strings.Fixed;

4

5package body Names_Ages is

6

7   procedure Reset (P : in out People) is

8   begin

9      null;

10   end Reset;

11

12   procedure Add (P    : in out People;

13                  Name :        String) is

14   begin

15      null;

16   end Add;

17

18   function Get (P    : People;

19                 Name : String) return Age_Type is

20   begin

21      return 0;

22   end Get;

23

24   procedure Update (P    : in out People;

25                     Name :        String;

26                     Age  :        Age_Type) is

27   begin

28      null;

29   end Update;

30

31   procedure Display (P : People) is

32   begin

33      null;

34   end Display;

35

36end Names_Ages;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Names_Ages;         use Names_Ages;

5

6procedure Main is

7   type Test_Case_Index is

8     (Names_Ages_Chk,

9      Get_Age_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      P : People;

13   begin

14      case TC is

15      when Names_Ages_Chk =>

16         Reset (P);

17         Add (P, "John");

18         Add (P, "Patricia");

19         Add (P, "Josh");

20         Display (P);

21         Update (P, "John",     18);

22         Update (P, "Patricia", 35);

23         Update (P, "Josh",     53);

24         Display (P);

25      when Get_Age_Chk =>

26         Reset (P);

27         Add (P, "Peter");

28         Update (P, "Peter", 45);

29         Put_Line ("Peter is "

30                   & Age_Type'Image (Get (P, "Peter"))

31                   & " years old.");

32      end case;

33   end Check;

34

35begin

36   if Argument_Count < 1 then

37      Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting...");

38      return;

39   elsif Argument_Count > 1 then

40      Ada.Text_IO.Put_Line ("Ignoring additional arguments...");

41   end if;

42

43   Check (Test_Case_Index'Value (Argument (1)));

44end Main;

Footnotes

Design by contracts

Price Range

Goal: use predicates to indicate the correct range of prices.

Steps:

1. Complete the Prices package.

1. Rewrite the type declaration of Price.

Requirements:

1. Type Price must use a predicate instead of a range.

Remarks:

1. As discussed in the course, ranges are a form of contract.

1. For example, the subtype Price below indicates that a value of this subtype must always be positive:

subtype Price is Amount range 0.0 .. Amount'Last;

2. Interestingly, you can replace ranges by predicates, which is the goal of this exercise.

prices.ads

1package Prices is

2

3   type Amount is delta 10.0 ** (-2) digits 12;

4

5   subtype Price is Amount range 0.0 .. Amount'Last;

6

7end Prices;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Prices;            use Prices;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Price_Range_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13

14      procedure Check_Range (A : Amount) is

15         P : constant Price := A;

16      begin

17         Put_Line ("Price: " & Price'Image (P));

18      end Check_Range;

19

20   begin

21      case TC is

22      when Price_Range_Chk =>

23         Check_Range (-2.0);

24      end case;

25   exception

26      when Constraint_Error =>

27         Put_Line ("Constraint_Error detected (NOT as expected).");

28      when Assert_Failure =>

29         Put_Line ("Assert_Failure detected (as expected).");

30   end Check;

31

32begin

33   if Argument_Count < 1 then

34      Put_Line ("ERROR: missing arguments! Exiting...");

35      return;

36   elsif Argument_Count > 1 then

37      Put_Line ("Ignoring additional arguments...");

38   end if;

39

40   Check (Test_Case_Index'Value (Argument (1)));

41end Main;

Pythagorean Theorem: Predicate

Goal: use the Pythagorean theorem as a predicate.

Steps:

1. Complete the Triangles package.

1. Add a predicate to the Right_Triangle type.

Requirements:

1. The Right_Triangle type must use the Pythagorean theorem as a predicate to ensure that its components are consistent.

Remarks:

1. As you probably remember, the Pythagoras' theorem#1 states that the square of the hypotenuse of a right triangle is equal to the sum of the squares of the other two sides.

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is record

6      H      : Length := 0;

7      --  Hypotenuse

8      C1, C2 : Length := 0;

9      --  Catheti / legs

10   end record;

11

12   function Init (H, C1, C2 : Length) return Right_Triangle is

13     ((H, C1, C2));

14

15end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Pythagorean Theorem: Precondition

Goal: use the Pythagorean theorem as a precondition.

Steps:

1. Complete the Triangles package.

1. Add a precondition to the Init function.

Requirements:

1. The Init function must use the Pythagorean theorem as a precondition to ensure that the input values are consistent.

Remarks:

1. In this exercise, you'll work again with the Right_Triangle type.

1. This time, your job is to use a precondition instead of a predicate.

2. The precondition is applied to the Init function, not to the Right_Triangle type.

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is record

6      H      : Length := 0;

7      --  Hypotenuse

8      C1, C2 : Length := 0;

9      --  Catheti / legs

10   end record;

11

12   function Init (H, C1, C2 : Length) return Right_Triangle is

13     ((H, C1, C2));

14

15end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Pythagorean Theorem: Postcondition

Goal: use the Pythagorean theorem as a postcondition.

Steps:

1. Complete the Triangles package.

1. Add a postcondition to the Init function.

Requirements:

1. The Init function must use the Pythagorean theorem as a postcondition to ensure that the returned object is consistent.

Remarks:

1. In this exercise, you'll work again with the Triangles package.

1. This time, your job is to apply a postcondition instead of a precondition to the Init function.

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is record

6      H      : Length := 0;

7      --  Hypotenuse

8      C1, C2 : Length := 0;

9      --  Catheti / legs

10   end record;

11

12   function Init (H, C1, C2 : Length) return Right_Triangle is

13     ((H, C1, C2));

14

15end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Pythagorean Theorem: Type Invariant

Goal: use the Pythagorean theorem as a type invariant.

Steps:

1. Complete the Triangles package.

1. Add a type invariant to the Right_Triangle type.

Requirements:

1. Right_Triangle is a private type.

1. It must use the Pythagorean theorem as a type invariant to ensure that its encapsulated components are consistent.

Remarks:

1. In this exercise, Right_Triangle is declared as a private type.

1. In this case, we use a type invariant for Right_Triangle to check the Pythagorean theorem.

2. As a bonus, after completing the exercise, you may analyze the effect that default values have on type invariants.

1. For example, the declaration of Right_Triangle uses zero as the default values of the three triangle lengths.

2. If you replace those default values with Length'Last, you'll get different results.

3. Make sure you understand why this is happening.

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is private;

6

7   function Init (H, C1, C2 : Length) return Right_Triangle;

8

9private

10

11   type Right_Triangle is record

12      H      : Length := 0;

13      --  Hypotenuse

14      C1, C2 : Length := 0;

15      --  Catheti / legs

16   end record;

17

18   function Init (H, C1, C2 : Length) return Right_Triangle is

19     ((H, C1, C2));

20

21end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Primary Color

Goal: extend a package for HTML colors so that it can handle primary colors.

Steps:

1. Complete the Color_Types package.

1. Declare the HTML_RGB_Color subtype.

2. Implement the To_Int_Color function.

Requirements:

1. The HTML_Color type is an enumeration that contains a list of HTML colors.

2. The To_RGB_Lookup_Table array implements a lookup-table to convert the colors into a hexadecimal value using RGB color components (i.e. Red, Green and Blue)

3. Function To_Int_Color extracts one of the RGB components of an HTML color and returns its hexadecimal value.

1. The function has two parameters:

- First parameter is the HTML color (HTML_Color type).

- Second parameter indicates which RGB component is to be extracted from the HTML color (HTML_RGB_Color subtype).

2. For example, if we call To_Int_Color (Salmon, Red), the function returns #FA,

- This is the hexadecimal value of the red component of the Salmon color.

- You can find further remarks below about this color as an example.

4. The HTML_RGB_Color subtype is limited to the primary RGB colors components (i.e. Red, Green and Blue).

1. This subtype is used to select the RGB component in calls to To_Int_Color.

2. You must use a predicate in the type declaration.

Remarks:

1. In this exercise, we reuse the code of the Colors: Lookup-Table exercise from the Arrays labs.

2. These are the hexadecimal values of the colors that we used in the original exercise:

Color

Value

Salmon

#FA8072

Firebrick

#B22222

Red

#FF0000

Darkred

#8B0000

Lime

#00FF00

Forestgreen

#228B22

Green

#008000

Darkgreen

#006400

Blue

#0000FF

Mediumblue

#0000CD

Darkblue

#00008B

3. You can extract the hexadecimal value of each primary color by splitting the values from the table above into three hexadecimal values with two digits each.

- For example, the hexadecimal value of Salmon is #FA8072, where:

- the first part of this hexadecimal value (#FA) corresponds to the red component,

- the second part (#80) corresponds to the green component, and

- the last part (#72) corresponds to the blue component.

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   subtype Int_Color is Integer range 0 .. 255;

17

18   function Image (I : Int_Color) return String;

19

20   type RGB is record

21      Red   : Int_Color;

22      Green : Int_Color;

23      Blue  : Int_Color;

24   end record;

25

26   function To_RGB (C : HTML_Color) return RGB;

27

28   function Image (C : RGB) return String;

29

30   type HTML_Color_RGB_Array is array (HTML_Color) of RGB;

31

32   To_RGB_Lookup_Table : constant HTML_Color_RGB_Array

33     := (Salmon      => (16#FA#, 16#80#, 16#72#),

34         Firebrick   => (16#B2#, 16#22#, 16#22#),

35         Red         => (16#FF#, 16#00#, 16#00#),

36         Darkred     => (16#8B#, 16#00#, 16#00#),

37         Lime        => (16#00#, 16#FF#, 16#00#),

38         Forestgreen => (16#22#, 16#8B#, 16#22#),

39         Green       => (16#00#, 16#80#, 16#00#),

40         Darkgreen   => (16#00#, 16#64#, 16#00#),

41         Blue        => (16#00#, 16#00#, 16#FF#),

42         Mediumblue  => (16#00#, 16#00#, 16#CD#),

43         Darkblue    => (16#00#, 16#00#, 16#8B#));

44

45   subtype HTML_RGB_Color is HTML_Color;

46

47   function To_Int_Color (C : HTML_Color;

48                          S : HTML_RGB_Color) return Int_Color;

49   --  Convert to hexadecimal value for the selected RGB component S

50

51end Color_Types;

color_types.adb

1with Ada.Integer_Text_IO;

2

3package body Color_Types is

4

5   function To_RGB (C : HTML_Color) return RGB is

6   begin

7      return To_RGB_Lookup_Table (C);

8   end To_RGB;

9

10   function To_Int_Color (C : HTML_Color;

11                          S : HTML_RGB_Color) return Int_Color is

12   begin

13      --  Implement function!

14      return 0;

15   end To_Int_Color;

16

17   function Image (I : Int_Color) return String is

18      subtype Str_Range is Integer range 1 .. 10;

19      S : String (Str_Range);

20   begin

21      Ada.Integer_Text_IO.Put (To    => S,

22                               Item  => I,

23                               Base  => 16);

24      return S;

25   end Image;

26

27   function Image (C : RGB) return String is

28   begin

29      return ("(Red => "      & Image (C.Red)

30              & ", Green => " & Image (C.Green)

31              & ", Blue => "  & Image (C.Blue)

32              &")");

33   end Image;

34

35end Color_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Color_Types;      use Color_Types;

5

6procedure Main is

7   type Test_Case_Index is

8     (HTML_Color_Red_Chk,

9      HTML_Color_Green_Chk,

10      HTML_Color_Blue_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13

14      procedure Check_HTML_Colors (S : HTML_RGB_Color) is

15      begin

16         Put_Line ("Selected: " & HTML_RGB_Color'Image (S));

17         for I in HTML_Color'Range loop

18            Put_Line (HTML_Color'Image (I) & " => "

19                      & Image (To_Int_Color (I, S)) & ".");

20         end loop;

21      end Check_HTML_Colors;

22

23   begin

24      case TC is

25         when HTML_Color_Red_Chk =>

26            Check_HTML_Colors (Red);

27         when HTML_Color_Green_Chk =>

28            Check_HTML_Colors (Green);

29         when HTML_Color_Blue_Chk =>

30            Check_HTML_Colors (Blue);

31      end case;

32   end Check;

33

34begin

35   if Argument_Count < 1 then

36      Put_Line ("ERROR: missing arguments! Exiting...");

37      return;

38   elsif Argument_Count > 1 then

39      Put_Line ("Ignoring additional arguments...");

40   end if;

41

42   Check (Test_Case_Index'Value (Argument (1)));

43end Main;

Footnotes

#1

https://en.wikipedia.org/wiki/Pythagorean_theorem

Exceptions

Uninitialized Value

Goal: implement an enumeration to avoid the use of uninitialized values.

Steps:

1. Implement the Options package.

1. Declare the Option enumeration type.

2. Declare the Uninitialized_Value exception.

3. Implement the Image function.

Requirements:

1. Enumeration Option contains:

1. the Uninitialized value, and

2. the actual options:

- Option_1,

- Option_2,

- Option_3.

2. Function Image returns a string for the Option type.

1. In case the argument to Image is Uninitialized, the function must raise the Uninitialized_Value exception.

Remarks:

1. In this exercise, we employ exceptions as a mechanism to avoid the use of uninitialized values for a certain type.

options.ads

1package Options is

2

3   --  Declare the Option enumeration type!

4   type Option is null record;

5

6   function Image (O : Option) return String;

7

8end Options;

options.adb

1package body Options is

2

3   function Image (O : Option) return String is

4   begin

5      return "";

6   end Image;

7

8end Options;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Exceptions;   use Ada.Exceptions;

4

5with Options;          use Options;

6

7procedure Main is

8   type Test_Case_Index is

9     (Options_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12

13      procedure Check (O : Option) is

14      begin

15         Put_Line (Image (O));

16      exception

17         when E : Uninitialized_Value =>

18            Put_Line (Exception_Message (E));

19      end Check;

20

21   begin

22      case TC is

23      when Options_Chk =>

24         for O in Option loop

25            Check (O);

26         end loop;

27      end case;

28   end Check;

29

30begin

31   if Argument_Count < 1 then

32      Put_Line ("ERROR: missing arguments! Exiting...");

33      return;

34   elsif Argument_Count > 1 then

35      Put_Line ("Ignoring additional arguments...");

36   end if;

37

38   Check (Test_Case_Index'Value (Argument (1)));

39end Main;

Numerical Exception

Goal: handle numerical exceptions in a test procedure.

Steps:

1. Add exception handling to the Check_Exception procedure.

Requirements:

1. The test procedure Num_Exception_Test from the Tests package below must be used in the implementation of Check_Exception.

2. The Check_Exception procedure must be extended to handle exceptions as follows:

1. If the exception raised by Num_Exception_Test is Constraint_Error, the procedure must display the message "Constraint_Error detected!" to the user.

2. Otherwise, it must display the message associated with the exception.

Remarks:

1. You can use the Exception_Message function to retrieve the message associated with an exception.

tests.ads

1package Tests is

2

3   type Test_ID is (Test_1, Test_2);

4

5   Custom_Exception : exception;

6

7   procedure Num_Exception_Test (ID : Test_ID);

8

9end Tests;

tests.adb

1package body Tests is

2

3   pragma Warnings (Off, "variable ""C"" is assigned but never read");

4

5   procedure Num_Exception_Test (ID : Test_ID) is

6      A, B, C : Integer;

7   begin

8      case ID is

9         when Test_1 =>

10            A := Integer'Last;

11            B := Integer'Last;

12            C := A + B;

13         when Test_2 =>

14            raise Custom_Exception with "Custom_Exception raised!";

15      end case;

16   end Num_Exception_Test;

17

18   pragma Warnings (On, "variable ""C"" is assigned but never read");

19

20end Tests;

check_exception.adb

1with Tests; use Tests;

2

3procedure Check_Exception (ID : Test_ID) is

4begin

5   Num_Exception_Test (ID);

6end Check_Exception;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Exceptions;   use Ada.Exceptions;

4

5with Tests;            use Tests;

6with Check_Exception;

7

8procedure Main is

9   type Test_Case_Index is

10     (Exception_1_Chk,

11      Exception_2_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      procedure Check_Handle_Exception (ID : Test_ID) is

16      begin

17         Check_Exception (ID);

18      exception

19         when Constraint_Error =>

20            Put_Line ("Constraint_Error"

21                      & " (raised by Check_Exception) detected!");

22         when E : others =>

23            Put_Line (Exception_Name (E)

24                      & " (raised by Check_Exception) detected!");

25      end Check_Handle_Exception;

26

27   begin

28      case TC is

29      when Exception_1_Chk =>

30         Check_Handle_Exception (Test_1);

31      when Exception_2_Chk =>

32         Check_Handle_Exception (Test_2);

33      end case;

34   end Check;

35

36begin

37   if Argument_Count < 1 then

38      Put_Line ("ERROR: missing arguments! Exiting...");

39      return;

40   elsif Argument_Count > 1 then

41      Put_Line ("Ignoring additional arguments...");

42   end if;

43

44   Check (Test_Case_Index'Value (Argument (1)));

45end Main;

Re-raising Exceptions

Goal: make use of exception re-raising in a test procedure.

Steps:

1. Declare new exception: Another_Exception.

2. Add exception re-raise to the Check_Exception procedure.

Requirements:

1. Exception Another_Exception must be declared in the Tests package.

2. Procedure Check_Exception must be extended to re-raise any exception. When an exception is detected, the procedure must:

1. display a user message (as implemented in the previous exercise), and then

2. Raise or re-raise exception depending on the exception that is being handled:

1. In case of Constraint_Error exception, re-raise the exception.

2. In all other cases, raise Another_Exception.

Remarks:

1. In this exercise, you should extend the implementation of the Check_Exception procedure from the previous exercise.

1. Naturally, you can use the code for the Check_Exception procedure from the previous exercise as a starting point.

tests.ads

1package Tests is

2

3   type Test_ID is (Test_1, Test_2);

4

5   Custom_Exception : exception;

6

7   procedure Num_Exception_Test (ID : Test_ID);

8

9end Tests;

tests.adb

1package body Tests is

2

3   pragma Warnings (Off, "variable ""C"" is assigned but never read");

4

5   procedure Num_Exception_Test (ID : Test_ID) is

6      A, B, C : Integer;

7   begin

8      case ID is

9         when Test_1 =>

10            A := Integer'Last;

11            B := Integer'Last;

12            C := A + B;

13         when Test_2 =>

14            raise Custom_Exception with "Custom_Exception raised!";

15      end case;

16   end Num_Exception_Test;

17

18   pragma Warnings (On, "variable ""C"" is assigned but never read");

19

20end Tests;

check_exception.ads

1with Tests; use Tests;

2

3procedure Check_Exception (ID : Test_ID);

check_exception.adb

1procedure Check_Exception (ID : Test_ID) is

2begin

3   Num_Exception_Test (ID);

4end Check_Exception;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Exceptions;   use Ada.Exceptions;

4

5with Tests;            use Tests;

6with Check_Exception;

7

8procedure Main is

9   type Test_Case_Index is

10     (Exception_1_Chk,

11      Exception_2_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      procedure Check_Handle_Exception (ID : Test_ID) is

16      begin

17         Check_Exception (ID);

18      exception

19         when Constraint_Error =>

20            Put_Line ("Constraint_Error"

21                      & " (raised by Check_Exception) detected!");

22         when E : others =>

23            Put_Line (Exception_Name (E)

24                      & " (raised by Check_Exception) detected!");

25      end Check_Handle_Exception;

26

27   begin

28      case TC is

29      when Exception_1_Chk =>

30         Check_Handle_Exception (Test_1);

31      when Exception_2_Chk =>

32         Check_Handle_Exception (Test_2);

33      end case;

34   end Check;

35

36begin

37   if Argument_Count < 1 then

38      Put_Line ("ERROR: missing arguments! Exiting...");

39      return;

40   elsif Argument_Count > 1 then

41      Put_Line ("Ignoring additional arguments...");

42   end if;

43

44   Check (Test_Case_Index'Value (Argument (1)));

45end Main;

Footnotes

Generics

Display Array

Goal: create a generic procedure that displays the elements of an array.

Steps:

1. Implement the generic procedure Display_Array.

Requirements:

1. Generic procedure Display_Array displays the elements of an array.

1. It uses the following scheme:

- First, it displays a header.

- Then, it displays the elements of the array.

2. When displaying the elements, it must:

- use one line per element, and

- include the corresponding index of the array.

3. This is the expected format:

<HEADER>

<index #1>: <element #1>

<index #2>: <element #2>

...

4. For example:

- For the following code:

procedure Test is

A : Int_Array (1 .. 2) := (1, 5);

begin

Display_Int_Array ("Elements of A", A);;

end Test;

- The output is:

Elements of A

1:  1

2:  5

2. These are the formal parameters of the procedure:

1. a range type T_Range for the the array;

2. a formal type T_Element for the elements of the array;

- This type must be declared in such a way that it can be mapped to any type in the instantiation — including record types.

3. an array type T_Array using the T_Range and T_Element types;

4. a function Image that converts a variable of T_Element type to a String.

display_array.ads

1generic

2procedure Display_Array (Header : String;

3                         A      : T_Array);

display_array.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Display_Array (Header : String;

4                         A      : T_Array) is

5begin

6   null;

7end Display_Array;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_Array;

5

6procedure Main is

7   type Test_Case_Index is (Int_Array_Chk,

8                            Point_Array_Chk);

9

10   procedure Test_Int_Array is

11      type Int_Array is array (Positive range <>) of Integer;

12

13      procedure Display_Int_Array is new

14        Display_Array (T_Range => Positive,

15                       T_Element => Integer,

16                       T_Array   => Int_Array,

17                       Image     => Integer'Image);

18

19      A : constant Int_Array (1 .. 5) := (1, 2, 5, 7, 10);

20   begin

21      Display_Int_Array ("Integers", A);

22   end Test_Int_Array;

23

24   procedure Test_Point_Array is

25      type Point is record

26         X : Float;

27         Y : Float;

28      end record;

29

30      type Point_Array is array (Natural range <>) of Point;

31

32      function Image (P : Point) return String is

33      begin

34         return "(" & Float'Image (P.X)

35           & ", " & Float'Image (P.Y) & ")";

36      end Image;

37

38      procedure Display_Point_Array is new

39        Display_Array (T_Range   => Natural,

40                       T_Element => Point,

41                       T_Array   => Point_Array,

42                       Image     => Image);

43

44      A : constant Point_Array (0 .. 3) := ((1.0, 0.5), (2.0, -0.5),

45                                            (5.0, 2.0), (-0.5, 2.0));

46   begin

47      Display_Point_Array ("Points", A);

48   end Test_Point_Array;

49

50   procedure Check (TC : Test_Case_Index) is

51   begin

52      case TC is

53         when Int_Array_Chk =>

54            Test_Int_Array;

55         when Point_Array_Chk =>

56            Test_Point_Array;

57      end case;

58   end Check;

59

60begin

61   if Argument_Count < 1 then

62      Put_Line ("ERROR: missing arguments! Exiting...");

63      return;

64   elsif Argument_Count > 1 then

65      Put_Line ("Ignoring additional arguments...");

66   end if;

67

68   Check (Test_Case_Index'Value (Argument (1)));

69end Main;

Average of Array of Float

Goal: create a generic function that calculates the average of an array of floating-point elements.

Steps:

1. Declare and implement the generic function Average.

Requirements:

1. Generic function Average calculates the average of an array containing floating-point values of arbitrary precision.

2. Generic function Average must contain the following formal parameters:

1. a range type T_Range for the array;

2. a formal type T_Element that can be mapped to floating-point types of arbitrary precision;

3. an array type T_Array using T_Range and T_Element;

Remarks:

1. You should use the Float type for the accumulator.

average.ads

1generic

2function Average (A : T_Array) return T_Element;

average.adb

1function Average (A : T_Array) return T_Element is

2begin

3   return 0.0;

4end Average;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Average;

5

6procedure Main is

7   type Test_Case_Index is (Float_Array_Chk,

8                            Digits_7_Float_Array_Chk);

9

10   procedure Test_Float_Array is

11      type Float_Array is array (Positive range <>) of Float;

12

13      function Average_Float is new

14        Average (T_Range   => Positive,

15                 T_Element => Float,

16                 T_Array   => Float_Array);

17

18      A : constant Float_Array (1 .. 5) := (1.0, 3.0, 5.0, 7.5, -12.5);

19   begin

20      Put_Line ("Average: " & Float'Image (Average_Float (A)));

21   end Test_Float_Array;

22

23   procedure Test_Digits_7_Float_Array is

24      type Custom_Float is digits 7 range 0.0 .. 1.0;

25

26      type Float_Array is

27        array (Integer range <>) of Custom_Float;

28

29      function Average_Float is new

30        Average (T_Range   => Integer,

31                 T_Element => Custom_Float,

32                 T_Array   => Float_Array);

33

34      A : constant Float_Array (-1 .. 3) := (0.5, 0.0, 1.0, 0.6, 0.5);

35   begin

36      Put_Line ("Average: "

37                & Custom_Float'Image (Average_Float (A)));

38   end Test_Digits_7_Float_Array;

39

40   procedure Check (TC : Test_Case_Index) is

41   begin

42      case TC is

43         when Float_Array_Chk =>

44            Test_Float_Array;

45         when Digits_7_Float_Array_Chk =>

46            Test_Digits_7_Float_Array;

47      end case;

48   end Check;

49

50begin

51   if Argument_Count < 1 then

52      Put_Line ("ERROR: missing arguments! Exiting...");

53      return;

54   elsif Argument_Count > 1 then

55      Put_Line ("Ignoring additional arguments...");

56   end if;

57

58   Check (Test_Case_Index'Value (Argument (1)));

59end Main;

Average of Array of Any Type

Goal: create a generic function that calculates the average of an array of elements of any arbitrary type.

Steps:

1. Declare and implement the generic function Average.

2. Implement the test procedure Test_Item.

1. Declare the F_IO package.

2. Implement the Get_Total function for the Item type.

3. Implement the Get_Price function for the Item type.

4. Declare the Average_Total function.

5. Declare the Average_Price function.

Requirements:

1. Generic function Average calculates the average of an array containing elements of any arbitrary type.

2. Generic function Average has the same formal parameters as in the previous exercise, except for:

1. T_Element, which is now a formal type that can be mapped to any arbitrary type.

2. To_Float, which is an additional formal parameter.

- To_Float is a function that converts the arbitrary element of T_Element type to the Float type.

3. Procedure Test_Item is used to test the generic Average procedure for a record type (Item).

1. Record type Item contains the Quantity and Price components.

4. The following functions have to implemented to be used for the formal To_Float function parameter:

1. For the Decimal type, the function is pretty straightforward: it simply returns the floating-point value converted from the decimal type.

2. For the Item type, two functions must be created to convert to floating-point type:

1. Get_Total, which returns the multiplication of the quantity and the price components of the Item type;

2. Get_Price, which returns just the price.

5. The generic function Average must be instantiated as follows:

1. For the Item type, you must:

1. declare the Average_Total function (as an instance of Average) using the Get_Total for the To_Float parameter;

2. declare the Average_Price function (as an instance of Average) using the Get_Price for the To_Float parameter.

6. You must use the Put procedure from Ada.Text_IO.Float_IO.

1. The generic standard package Ada.Text_IO.Float_IO must be instantiated as F_IO in the test procedures.

2. This is the specification of the Put procedure, as described in the appendix A.10.9 of the Ada Reference Manual:

procedure Put(Item : in Num;

Fore : in Field := Default_Fore;

Aft  : in Field := Default_Aft;

Exp  : in Field := Default_Exp);

3. This is the expected format when calling Put from Float_IO:

Function

Fore

Aft

Exp

Test_Item

3

2

0

Remarks:

1. In this exercise, you'll abstract the Average function from the previous exercises a step further.

1. In this case, the function shall be able to calculate the average of any arbitrary type — including arrays containing elements of record types.

2. Since record types can be composed by many components of different types, we need to provide a way to indicate which component (or components) of the record will be used when calculating the average of the array.

3. This problem is solved by specifying a To_Float function as a formal parameter, which converts the arbitrary element of T_Element type to the Float type.

4. In the implementation of the Average function, we use the To_Float function and calculate the average using a floating-point variable.

average.ads

1generic

2function Average (A : T_Array) return Float;

average.adb

1function Average (A : T_Array) return Float is

2begin

3   null;

4end Average;

test_item.ads

1procedure Test_Item;

test_item.adb

1with Ada.Text_IO;      use Ada.Text_IO;

2

3with Average;

4

5procedure Test_Item is

6   type Amount is delta 0.01 digits 12;

7

8   type Item is record

9      Quantity : Natural;

10      Price    : Amount;

11   end record;

12

13   type Item_Array is

14     array (Positive range <>) of Item;

15

16   A : constant Item_Array (1 .. 4)

17     := ((Quantity =>  5,   Price => 10.00),

18         (Quantity => 80,   Price =>  2.50),

19         (Quantity => 40,   Price =>  5.00),

20         (Quantity => 20,   Price => 12.50));

21

22begin

23   Put ("Average per item & quantity: ");

24   F_IO.Put (Average_Total (A));

25   New_Line;

26

27   Put ("Average price:               ");

28   F_IO.Put (Average_Price (A));

29   New_Line;

30end Test_Item;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Test_Item;

5

6procedure Main is

7   type Test_Case_Index is (Item_Array_Chk);

8

9   procedure Check (TC : Test_Case_Index) is

10   begin

11      case TC is

12         when Item_Array_Chk =>

13            Test_Item;

14      end case;

15   end Check;

16

17begin

18   if Argument_Count < 1 then

19      Put_Line ("ERROR: missing arguments! Exiting...");

20      return;

21   elsif Argument_Count > 1 then

22      Put_Line ("Ignoring additional arguments...");

23   end if;

24

25   Check (Test_Case_Index'Value (Argument (1)));

26end Main;

Generic list

Goal: create a system based on a generic list to add and displays elements.

Steps:

1. Declare and implement the generic package Gen_List.

1. Implement the Init procedure.

2. Implement the Add procedure.

3. Implement the Display procedure.

Requirements:

1. Generic package Gen_List must have the following subprograms:

1. Procedure Init initializes the list.

2. Procedure Add adds an item to the list.

1. This procedure must contain a Status output parameter that is set to False when the list was full — i.e. if the procedure failed while trying to add the item;

3. Procedure Display displays the complete list.

1. This includes the name of the list and its elements — using one line per element.

2. This is the expected format:

<NAME>

<element #1>

<element #2>

...

2. Generic package Gen_List has these formal parameters:

1. an arbitrary formal type Item;

2. an unconstrained array type Items of Item element with positive range;

3. the Name parameter containing the name of the list;

- This must be a formal input object of String type.

- It must be used in the Display procedure.

4. an actual array List_Array to store the list;

- This must be a formal in out object of Items type.

5. the variable Last to store the index of the last element;

- This must be a formal in out object of Natural type.

6. a procedure Put for the Item type.

- This procedure is used in the Display procedure to display individual elements of the list.

3. The test procedure Test_Int is used to test a list of elements of Integer type.

4. For both test procedures, you must:

1. add missing type declarations;

2. declare and implement a Put procedure for individual elements of the list;

3. declare instances of the Gen_List package.

- For the Test_Int procedure, declare the Int_List package.

Remarks:

1. In previous labs, you've been implementing lists for a variety of types.

- The List of Names exercise from the Arrays labs is an example.

- In this exercise, you have to abstract those implementations to create the generic Gen_List package.

gen_list.ads

1generic

2package Gen_List is

3

4   procedure Init;

5

6   procedure Add (I      :     Item;

7                  Status : out Boolean);

8

9   procedure Display;

10

11end Gen_List;

gen_list.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Gen_List is

4

5   procedure Init is

6   begin

7      null;

8   end Init;

9

10   procedure Add (I      :     Item;

11                  Status : out Boolean) is

12   begin

13      null;

14   end Add;

15

16   procedure Display is

17   begin

18      null;

19   end Display;

20

21end Gen_List;

test_int.ads

1procedure Test_Int;

test_int.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3with Gen_List;

4

5procedure Test_Int is

6

7   type Integer_Array is array (Positive range <>) of Integer;

8

9   A : Integer_Array (1 .. 3);

10   L : Natural;

11

12   Success : Boolean;

13

14   procedure Display_Add_Success (Success : Boolean) is

15   begin

16      if Success then

17         Put_Line ("Added item successfully!");

18      else

19         Put_Line ("Couldn't add item!");

20      end if;

21

22   end Display_Add_Success;

23

24begin

25   Int_List.Init;

26

27   Int_List.Add (2, Success);

28   Display_Add_Success (Success);

29

30   Int_List.Add (5, Success);

31   Display_Add_Success (Success);

32

33   Int_List.Add (7, Success);

34   Display_Add_Success (Success);

35

36   Int_List.Add (8, Success);

37   Display_Add_Success (Success);

38

39   Int_List.Display;

40end Test_Int;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Test_Int;

5

6procedure Main is

7   type Test_Case_Index is (Int_Chk);

8

9   procedure Check (TC : Test_Case_Index) is

10   begin

11      case TC is

12         when Int_Chk =>

13            Test_Int;

14      end case;

15   end Check;

16

17begin

18   if Argument_Count < 1 then

19      Put_Line ("ERROR: missing arguments! Exiting...");

20      return;

21   elsif Argument_Count > 1 then

22      Put_Line ("Ignoring additional arguments...");

23   end if;

24

25   Check (Test_Case_Index'Value (Argument (1)));

26end Main;

Footnotes

Imperative language

For the exercises below (except for the first one), don't worry about the details of the Main procedure. You should just focus on implementing the application in the subprogram specified by the exercise.

Hello World

Goal: create a "Hello World!" application.

Steps:

1. Complete the Main procedure.

Requirements:

1. The application must display the message "Hello World!".

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4begin

5   --  Implement the application here!

6   null;

7end Main;

Greetings

Goal: create an application that greets a person.

Steps:

1. Complete the Greet procedure.

Requirements:

1. Given an input string <name>, procedure Greet must display the message "Hello <name>!".

1. For example, if the name is "John", it displays the message "Hello John!".

Remarks:

1. You can use the concatenation operator (&).

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4procedure Main is

5

6   procedure Greet (Name : String) is

7   begin

8      --  Implement the application here!

9      null;

10   end Greet;

11

12begin

13   if Argument_Count < 1 then

14      Put_Line ("ERROR: missing arguments! Exiting...");

15      return;

16   elsif Argument_Count > 1 then

17      Put_Line ("Ignoring additional arguments...");

18   end if;

19

20   Greet (Argument (1));

21end Main;

Positive Or Negative

Goal: create an application that classifies integer numbers.

Steps:

1. Complete the Classify_Number procedure.

Requirements:

1. Given an integer number X, procedure Classify_Number must classify X as positive, negative or zero and display the result:

1. If X > 0, it displays Positive.

2. If X < 0, it displays Negative.

3. If X = 0, it displays Zero.

classify_number.ads

1procedure Classify_Number (X : Integer);

classify_number.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Classify_Number (X : Integer) is

4begin

5   --  Implement the application here!

6   null;

7end Classify_Number;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Classify_Number;

5

6procedure Main is

7   A : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   A := Integer'Value (Argument (1));

17

18   Classify_Number (A);

19end Main;

Numbers

Goal: create an application that displays numbers in a specific order.

Steps:

1. Complete the Display_Numbers procedure.

Requirements:

1. Given two integer numbers, Display_Numbers displays all numbers in the range starting with the smallest number.

display_numbers.ads

1procedure Display_Numbers (A, B : Integer);

display_numbers.adb

1procedure Display_Numbers (A, B : Integer) is

2begin

3   --  Implement the application here!

4   null;

5end Display_Numbers;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_Numbers;

5

6procedure Main is

7   A, B : Integer;

8begin

9   if Argument_Count < 2 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 2 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   A := Integer'Value (Argument (1));

17   B := Integer'Value (Argument (2));

18

19   Display_Numbers (A, B);

20end Main;

Footnotes

Modular Programming

Months

Goal: create a package to display the months of the year.

Steps:

1. Convert the Months procedure below to a package.

2. Create the specification and body of the Months package.

Requirements:

1. Months must contain the declaration of strings for each month of the year, which are stored in three-character constants based on the month's name.

- For example, the string "January" is stored in the constant Jan. These strings are then used by the Display_Months procedure, which is also part of the Months package.

Remarks:

1. The goal of this exercise is to create the Months package.

1. In the code below, Months is declared as a procedure.

- Therefore, we need to convert it into a real package.

2. You have to modify the procedure declaration and implementation in the code below, so that it becomes a package specification and a package body.

months.ads

1--  Create specification for Months package, which includes

2--  the declaration of the Display_Months procedure.

3--

4procedure Months;

months.adb

1--  Create body of Months package, which includes

2--  the implementation of the Display_Months procedure.

3--

4procedure Months is

5

6   procedure Display_Months is

7   begin

8      Put_Line ("Months:");

9      Put_Line ("- " & Jan);

10      Put_Line ("- " & Feb);

11      Put_Line ("- " & Mar);

12      Put_Line ("- " & Apr);

13      Put_Line ("- " & May);

14      Put_Line ("- " & Jun);

15      Put_Line ("- " & Jul);

16      Put_Line ("- " & Aug);

17      Put_Line ("- " & Sep);

18      Put_Line ("- " & Oct);

19      Put_Line ("- " & Nov);

20      Put_Line ("- " & Dec);

21   end Display_Months;

22

23begin

24   null;

25end Months;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Months;           use Months;

5

6procedure Main is

7

8   type Test_Case_Index is

9     (Months_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12   begin

13      case TC is

14         when Months_Chk =>

15            Display_Months;

16      end case;

17   end Check;

18

19begin

20   if Argument_Count < 1 then

21      Put_Line ("ERROR: missing arguments! Exiting...");

22      return;

23   elsif Argument_Count > 1 then

24      Put_Line ("Ignoring additional arguments...");

25   end if;

26

27   Check (Test_Case_Index'Value (Argument (1)));

28end Main;

Operations

Goal: create a package to perform basic mathematical operations.

Steps:

1. Implement the Operations package.

1. Declare and implement the Add function.

2. Declare and implement the Subtract function.

3. Declare and implement the Multiply: function.

4. Declare and implement the Divide function.

2. Implement the Operations.Test package

1. Declare and implement the Display procedure.

Requirements:

1. Package Operations contains functions for each of the four basic mathematical operations for parameters of Integer type:

1. Function Add performs the addition of A and B and returns the result;

2. Function Subtract performs the subtraction of A and B and returns the result;

3. Function Multiply performs the multiplication of A and B and returns the result;

4. Function Divide performs the division of A and B and returns the result.

2. Package Operations.Test contains the test environment:

1. Procedure Display must use the functions from the parent (Operations) package as indicated by the template in the code below.

operations.ads

1package Operations is

2

3   --  Create specification for Operations package, including the

4   --  declaration of the functions mentioned above.

5   --

6

7end Operations;

operations.adb

1package body Operations is

2

3   --  Create body of Operations package.

4   --

5

6end Operations;

operations-test.ads

1package Operations.Test is

2

3   --  Create specification for Operations package, including the

4   --  declaration of the Display procedure:

5   --

6   --   procedure Display (A, B : Integer);

7   --

8

9end Operations.Test;

operations-test.adb

1package body Operations.Test is

2

3   --  Implement body of Operations.Test package.

4   --

5

6   procedure Display (A, B : Integer) is

7      A_Str : constant String := Integer'Image (A);

8      B_Str : constant String := Integer'Image (B);

9   begin

10      Put_Line ("Operations:");

11      Put_Line (A_Str & " + " & B_Str & " = "

12                & Integer'Image (Add (A, B))

13                & ",");

14      --  Use the line above as a template and add the rest of the

15      --  implementation for Subtract, Multiply and Divide.

16   end Display;

17

18end Operations.Test;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Operations;

5with Operations.Test;  use Operations.Test;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Operations_Chk,

11      Operations_Display_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14   begin

15      case TC is

16         when Operations_Chk =>

17            Put_Line ("Add (100, 2) = "

18                      & Integer'Image (Operations.Add (100, 2)));

19            Put_Line ("Subtract (100, 2) = "

20                      & Integer'Image (Operations.Subtract (100, 2)));

21            Put_Line ("Multiply (100, 2) = "

22                      & Integer'Image (Operations.Multiply (100, 2)));

23            Put_Line ("Divide (100, 2) = "

24                      & Integer'Image (Operations.Divide (100, 2)));

25         when Operations_Display_Chk =>

26            Display (10, 5);

27            Display ( 1, 2);

28      end case;

29   end Check;

30

31begin

32   if Argument_Count < 1 then

33      Put_Line ("ERROR: missing arguments! Exiting...");

34      return;

35   elsif Argument_Count > 1 then

36      Put_Line ("Ignoring additional arguments...");

37   end if;

38

39   Check (Test_Case_Index'Value (Argument (1)));

40end Main;

Footnotes

More About Types

Aggregate Initialization

Goal: initialize records and arrays using aggregates.

Steps:

1. Implement the Aggregates package.

1. Create the record type Rec.

2. Create the array type Int_Arr.

3. Implement the Init procedure that outputs a record of Rec type.

4. Implement the Init_Some procedure.

5. Implement the Init procedure that outputs an array of Int_Arr type.

Requirements:

1. Record type Rec has four components of Integer type. These are the components with the corresponding default values:

- W = 10

- X = 11

- Y = 12

- Z = 13

2. Array type Int_Arr has 20 elements of Integer type (with indices ranging from 1 to 20).

3. The first Init procedure outputs a record of Rec type where:

1. X is initialized with 100,

2. Y is initialized with 200, and

3. the remaining elements use their default values.

4. Procedure Init_Some outputs an array of Int_Arr type where:

1. the first five elements are initialized with the value 99, and

2. the remaining elements are initialized with the value 100.

5. The second Init procedure outputs an array of Int_Arr type where:

1. all elements are initialized with the value 5.

aggregates.ads

1package Aggregates is

2

3   --  type Rec is ...;

4

5   --  type Int_Arr is ...;

6

7   procedure Init;

8

9   --  procedure Init_Some ...;

10

11   --  procedure Init ...;

12

13end Aggregates;

aggregates.adb

1package body Aggregates is

2

3   procedure Init is null;

4

5end Aggregates;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Aggregates;        use Aggregates;

5

6procedure Main is

7   --  Remark: the following line is not relevant.

8   F   : array (1 .. 10) of Float := (others => 42.42)

9     with Unreferenced;

10

11   type Test_Case_Index is

12     (Default_Rec_Chk,

13      Init_Rec_Chk,

14      Init_Some_Arr_Chk,

15      Init_Arr_Chk);

16

17   procedure Check (TC : Test_Case_Index) is

18      A : Int_Arr;

19      R : Rec;

20      DR : constant Rec := (others => <>);

21   begin

22      case TC is

23         when Default_Rec_Chk =>

24            R := DR;

25            Put_Line ("Record Default:");

26            Put_Line ("W => " & Integer'Image (R.W));

27            Put_Line ("X => " & Integer'Image (R.X));

28            Put_Line ("Y => " & Integer'Image (R.Y));

29            Put_Line ("Z => " & Integer'Image (R.Z));

30         when Init_Rec_Chk =>

31            Init (R);

32            Put_Line ("Record Init:");

33            Put_Line ("W => " & Integer'Image (R.W));

34            Put_Line ("X => " & Integer'Image (R.X));

35            Put_Line ("Y => " & Integer'Image (R.Y));

36            Put_Line ("Z => " & Integer'Image (R.Z));

37         when Init_Some_Arr_Chk =>

38            Init_Some (A);

39            Put_Line ("Array Init_Some:");

40            for I in A'Range loop

41               Put_Line (Integer'Image (I) & " "

42                         & Integer'Image (A (I)));

43            end loop;

44         when Init_Arr_Chk =>

45            Init (A);

46            Put_Line ("Array Init:");

47            for I in A'Range loop

48               Put_Line (Integer'Image (I) & " "

49                         & Integer'Image (A (I)));

50            end loop;

51      end case;

52   end Check;

53

54begin

55   if Argument_Count < 1 then

56      Put_Line ("ERROR: missing arguments! Exiting...");

57      return;

58   elsif Argument_Count > 1 then

59      Put_Line ("Ignoring additional arguments...");

60   end if;

61

62   Check (Test_Case_Index'Value (Argument (1)));

63end Main;

Versioning

Goal: implement a simple package for source-code versioning.

Steps:

1. Implement the Versioning package.

1. Declare the record type Version.

2. Implement the Convert function that returns a string.

3. Implement the Convert function that returns a floating-point number.

Requirements:

1. Record type Version has the following components of Natural type:

1. Major,

2. Minor, and

3. Maintenance.

2. The first Convert function returns a string containing the version number.

3. The second Convert function returns a floating-point value.

1. For this floating-point value:

1. the number before the decimal point must correspond to the major number, and

2. the number after the decimal point must correspond to the minor number.

3. the maintenance number is ignored.

2. For example, version "1.3.5" is converted to the floating-point value 1.3.

3. An obvious limitation of this function is that it can only handle one-digit numbers for the minor component.

- For example, we cannot convert version "1.10.0" to a reasonable value with the approach described above. The result of the call Convert ((1, 10, 0)) is therefore unspecified.

- For the scope of this exercise, only version numbers with one-digit components are checked.

Remarks:

1. We use overloading for the Convert functions.

2. For the function Convert that returns a string, you can make use of the Image_Trim function, as indicated in the source-code below — see package body of Versioning.

versioning.ads

1package Versioning is

2

3   --  type Version is record...

4

5   --  function Convert ...

6

7   --  function Convert

8

9end Versioning;

versioning.adb

1with Ada.Strings; use Ada.Strings;

2with Ada.Strings.Fixed; use Ada.Strings.Fixed;

3

4package body Versioning is

5

6   function Image_Trim (N : Natural) return String is

7      S_N : constant String := Trim (Natural'Image (N), Left);

8   begin

9      return S_N;

10   end Image_Trim;

11

12   --  function Convert ...

13   --     S_Major : constant String := Image_Trim (V.Major);

14   --     S_Minor : constant String := Image_Trim (V.Minor);

15   --     S_Maint : constant String := Image_Trim (V.Maintenance);

16   --  begin

17   --  end Convert;

18

19   --  function Convert ...

20   --  begin

21   --  end Convert;

22

23end Versioning;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Versioning;        use Versioning;

5

6procedure Main is

7   type Test_Case_Index is

8     (Ver_String_Chk,

9      Ver_Float_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      V : constant Version := (1, 3, 23);

13   begin

14      case TC is

15         when Ver_String_Chk =>

16            Put_Line (Convert (V));

17         when Ver_Float_Chk =>

18            Put_Line (Float'Image (Convert (V)));

19      end case;

20   end Check;

21

22begin

23   if Argument_Count < 1 then

24      Put_Line ("ERROR: missing arguments! Exiting...");

25      return;

26   elsif Argument_Count > 1 then

27      Put_Line ("Ignoring additional arguments...");

28   end if;

29

30   Check (Test_Case_Index'Value (Argument (1)));

31end Main;

Simple todo list

Goal: implement a simple to-do list system.

Steps:

1. Implement the Todo_Lists package.

1. Declare the Todo_Item type.

2. Declare the Todo_List type.

3. Implement the Add procedure.

4. Implement the Display procedure.

Requirements:

1. Todo_Item type is used to store a to-do item.

1. It should be implemented as an access type to strings.

2. Todo_Items type is an array of to-do items.

1. It should be implemented as an unconstrained array with positive range.

3. Todo_List type is the container for all to-do items.

1. This record type must have a discriminant for the maximum number of elements of the list.

2. In order to store the to-do items, it must contain a component named Items of Todo_Items type.

3. Don't forget to keep track of the last element added to the list!

- You should declare a Last component in the record.

4. Procedure Add adds items (of Todo_Item type) to the list (of Todo_List type).

1. This requires allocating a string for the access type.

2. An item can only be added to the list if the list isn't full yet — see next point for details on error handling.

5. Since the number of items that can be stored on the list is limited, the list might eventually become full in a call to Add.

1. You must write code in the implementation of the Add procedure that verifies this condition.

2. If the procedure detects that the list is full, it must display the following message: "ERROR: list is full!".

6. Procedure Display is used to display all to-do items.

1. The header (first line) must be TO-DO LIST.

2. It must display one item per line.

Remarks:

1. We use access types and unconstrained arrays in the implementation of the Todo_Lists package.

todo_lists.ads

1package Todo_Lists is

2

3   --  Replace by actual type declaration

4   type Todo_Item is null record;

5

6   --  Replace by actual type declaration

7   type Todo_Items is null record;

8

9   --  Replace by actual type declaration

10   type Todo_List is null record;

11

12   procedure Add (Todos : in out Todo_List;

13                  Item  : String);

14

15   procedure Display (Todos : Todo_List);

16

17end Todo_Lists;

todo_lists.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Todo_Lists is

4

5   procedure Add (Todos : in out Todo_List;

6                  Item  : String) is

7   begin

8      Put_Line ("ERROR: list is full!");

9   end Add;

10

11   procedure Display (Todos : Todo_List) is

12   begin

13      null;

14   end Display;

15

16end Todo_Lists;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Todo_Lists;        use Todo_Lists;

5

6procedure Main is

7   type Test_Case_Index is

8     (Todo_List_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11      T : Todo_List (10);

12   begin

13      case TC is

14         when Todo_List_Chk =>

15            Add (T, "Buy milk");

16            Add (T, "Buy tea");

17            Add (T, "Buy present");

18            Add (T, "Buy tickets");

19            Add (T, "Pay electricity bill");

20            Add (T, "Schedule dentist appointment");

21            Add (T, "Call sister");

22            Add (T, "Revise spreasheet");

23            Add (T, "Edit entry page");

24            Add (T, "Select new design");

25            Add (T, "Create upgrade plan");

26            Display (T);

27      end case;

28   end Check;

29

30begin

31   if Argument_Count < 1 then

32      Put_Line ("ERROR: missing arguments! Exiting...");

33      return;

34   elsif Argument_Count > 1 then

35      Put_Line ("Ignoring additional arguments...");

36   end if;

37

38   Check (Test_Case_Index'Value (Argument (1)));

39end Main;

Price list

Goal: implement a list containing prices

Steps:

1. Implement the Price_Lists package.

1. Declare the Price_Type type.

2. Declare the Price_List record.

3. Implement the Reset procedure.

4. Implement the Add procedure.

5. Implement the Get function.

6. Implement the Display procedure.

Requirements:

1. Price_Type is a decimal fixed-point data type with a delta of two digits (e.g. 0.01) and twelve digits in total.

2. Price_List is a record type that contains the price list.

1. This record type must have a discriminant for the maximum number of elements of the list.

3. Procedure Reset resets the list.

4. Procedure Add adds a price to the list.

1. You should keep track of the last element added to the list.

5. Function Get retrieves a price from the list using an index.

1. This function returns a record instance of Price_Result type.

2. Price_Result is a variant record containing:

1. the Boolean component Ok, and

2. the component Price (of Price_Type).

3. The returned value of Price_Result type is one of the following:

1. If the index specified in a call to Get contains a valid (initialized) price, then

- Ok is set to True, and

- the Price component contains the price for that index.

2. Otherwise:

- Ok is set to False, and

- the Price component is not available.

6. Procedure Display shows all prices from the list.

1. The header (first line) must be PRICE LIST.

2. The remaining lines contain one price per line.

3. For example:

- For the following code:

procedure Test is

L : Price_List (10);

begin

Reset (L);

Add (L, 1.45);

Add (L, 2.37);

Display (L);

end Test;

- The output is:

PRICE LIST

1.45

2.37

Remarks:

1. To implement the package, you'll use the following features of the Ada language:

1. decimal fixed-point types;

2. records with discriminants;

3. dynamically-sized record types;

4. variant records.

2. For record type Price_List, you may use an unconstrained array as a component of the record and use the discriminant in the component declaration.

price_lists.ads

1package Price_Lists is

2

3   --  Replace by actual type declaration

4   type Price_Type is new Float;

5

6   --  Replace by actual type declaration

7   type Price_List is null record;

8

9   --  Replace by actual type declaration

10   type Price_Result is null record;

11

12   procedure Reset (Prices : in out Price_List);

13

14   procedure Add (Prices : in out Price_List;

15                  Item   : Price_Type);

16

17   function Get (Prices : Price_List;

18                 Idx    : Positive) return Price_Result;

19

20   procedure Display (Prices : Price_List);

21

22end Price_Lists;

price_lists.adb

1package body Price_Lists is

2

3   procedure Reset (Prices : in out Price_List) is

4   begin

5      null;

6   end Reset;

7

8   procedure Add (Prices : in out Price_List;

9                  Item   : Price_Type) is

10   begin

11      null;

12   end Add;

13

14   function Get (Prices : Price_List;

15                 Idx    : Positive) return Price_Result is

16   begin

17      null;

18   end Get;

19

20   procedure Display (Prices : Price_List) is

21   begin

22      null;

23   end Display;

24

25end Price_Lists;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Price_Lists;       use Price_Lists;

5

6procedure Main is

7   type Test_Case_Index is

8     (Price_Type_Chk,

9      Price_List_Chk,

10      Price_List_Get_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13      L : Price_List (10);

14

15      procedure Local_Init_List is

16      begin

17         Reset (L);

18         Add (L, 1.45);

19         Add (L, 2.37);

20         Add (L, 3.21);

21         Add (L, 4.14);

22         Add (L, 5.22);

23         Add (L, 6.69);

24         Add (L, 7.77);

25         Add (L, 8.14);

26         Add (L, 9.99);

27         Add (L, 10.01);

28      end Local_Init_List;

29

30      procedure Get_Display (Idx : Positive) is

31         R : constant Price_Result := Get (L, Idx);

32      begin

33         Put_Line ("Attempt Get # " & Positive'Image (Idx));

34         if R.Ok then

35            Put_Line ("Element # " & Positive'Image (Idx)

36                      & " => "     & Price_Type'Image (R.Price));

37         else

38            declare

39            begin

40               Put_Line ("Element # " & Positive'Image (Idx)

41                         & " => "     & Price_Type'Image (R.Price));

42            exception

43               when others =>

44                  Put_Line ("Element not available (as expected)");

45            end;

46         end if;

47

48      end Get_Display;

49

50   begin

51      case TC is

52         when Price_Type_Chk =>

53            Put_Line ("The delta    value of Price_Type is "

54                      & Price_Type'Image (Price_Type'Delta) & ";");

55            Put_Line ("The minimum  value of Price_Type is "

56                      & Price_Type'Image (Price_Type'First) & ";");

57            Put_Line ("The maximum  value of Price_Type is "

58                      & Price_Type'Image (Price_Type'Last)  & ";");

59         when Price_List_Chk =>

60            Local_Init_List;

61            Display (L);

62         when Price_List_Get_Chk =>

63            Local_Init_List;

64            Get_Display (5);

65            Get_Display (40);

66      end case;

67   end Check;

68

69begin

70   if Argument_Count < 1 then

71      Put_Line ("ERROR: missing arguments! Exiting...");

72      return;

73   elsif Argument_Count > 1 then

74      Put_Line ("Ignoring additional arguments...");

75   end if;

76

77   Check (Test_Case_Index'Value (Argument (1)));

78end Main;

Footnotes

Object-oriented programming

Simple type extension

Goal: work with type extensions using record types containing numeric components.

Steps:

1. Implement the Type_Extensions package.

1. Declare the record type T_Float.

2. Declare the record type T_Mixed

3. Implement the Init function for the T_Float type with a floating-point input parameter.

4. Implement the Init function for the T_Float type with an integer input parameter.

5. Implement the Image function for the T_Float type.

6. Implement the Init function for the T_Mixed type with a floating-point input parameter.

7. Implement the Init function for the T_Mixed type with an integer input parameter.

8. Implement the Image function for the T_Mixed type.

Requirements:

1. Record type T_Float contains the following component:

1. F, a floating-point type.

2. Record type T_Mixed is derived from the T_Float type.

1. T_Mixed extends T_Float with the following component:

1. I, an integer component.

2. Both components must be numerically synchronized:

- For example, if the floating-point component contains the value 2.0, the value of the integer component must be 2.

- In order to simplify the implementation, you can simply use Integer (F) to convert a floating-point variable F to integer.

3. Function Init returns an object of the corresponding type (T_Float or T_Mixed).

1. For each type, two versions of Init must be declared:

1. one with a floating-point input parameter,

2. another with an integer input parameter.

2. The parameter to Init is used to initialize the record components.

4. Function Image returns a string for the components of the record type.

1. In case of the Image function for the T_Float type, the string must have the format "{ F => <float value> }".

- For example, the call Image (T_Float'(Init (8.0)))) should return the string "{ F => 8.00000E+00 }".

2. In case of the Image function for the T_Mixed type, the string must have the format "{ F => <float value>, I => <integer value> }".

- For example, the call Image (T_Mixed'(Init (8.0)))) should return the string "{ F => 8.00000E+00, I => 8 }".

type_extensions.ads

1package Type_Extensions is

2

3   --  Create declaration of T_Float type!

4   type T_Float is null record;

5

6   --  function Init ...

7

8   --  function Image ...

9

10   --  Create declaration of T_Mixed type!

11   type T_Mixed is null record;

12

13end Type_Extensions;

type_extensions.adb

1package body Type_Extensions is

2

3end Type_Extensions;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Type_Extensions;  use Type_Extensions;

5

6procedure Main is

7

8   type Test_Case_Index is

9     (Type_Extension_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      F1, F2 : T_Float;

13      M1, M2 : T_Mixed;

14   begin

15      case TC is

16      when Type_Extension_Chk =>

17         F1 := Init (2.0);

18         F2 := Init (3);

19         M1 := Init (4.0);

20         M2 := Init (5);

21

22         if M2 in T_Float'Class then

23           Put_Line ("T_Mixed is in T_Float'Class as expected");

24         end if;

25

26         Put_Line ("F1: " & Image (F1));

27         Put_Line ("F2: " & Image (F2));

28         Put_Line ("M1: " & Image (M1));

29         Put_Line ("M2: " & Image (M2));

30      end case;

31   end Check;

32

33begin

34   if Argument_Count < 1 then

35      Put_Line ("ERROR: missing arguments! Exiting...");

36      return;

37   elsif Argument_Count > 1 then

38      Put_Line ("Ignoring additional arguments...");

39   end if;

40

41   Check (Test_Case_Index'Value (Argument (1)));

42end Main;

Online Store

Goal: create an online store for the members of an association.

Steps:

1. Implement the Online_Store package.

1. Declare the Member type.

2. Declare the Full_Member type.

3. Implement the Get_Status function for the Member type.

4. Implement the Get_Price function for the Member type.

5. Implement the Get_Status function for the Full_Member type.

6. Implement the Get_Price function for the Full_Member type.

2. Implement the Online_Store.Tests child package.

1. Implement the Simple_Test procedure.

Requirements:

1. Package Online_Store implements an online store application for the members of an association.

1. In this association, members can have one of the following status:

- associate member, or

- full member.

2. Function Get_Price returns the correct price of an item.

1. Associate members must pay the full price when they buy items from the online store.

2. Full members can get a discount.

1. The discount rate can be different for each full member — depending on factors that are irrelevant for this exercise.

3. Package Online_Store has following types:

1. Percentage type, which represents a percentage ranging from 0.0 to 1.0.

2. Member type for associate members containing following components:

- Start, which indicates the starting year of the membership.

- This information is common for both associate and full members.

- You can use the Year_Number type from the standard Ada.Calendar package for this component.

3. Full_Member type for full members.

1. This type must extend the Member type above.

2. It contains the following additional component:

- Discount, which indicates the discount rate that the full member gets in the online store.

- This component must be of Percentage type.

4. For the Member and Full_Member types, you must implement the following functions:

1. Get_Status, which returns a string with the membership status.

- The string must be "Associate Member" or "Full Member", respectively.

2. Get_Price, which returns the adapted price of an item — indicating the actual due amount.

- For example, for a full member with a 10% discount rate, the actual due amount of an item with a price of 100.00 is 90.00.

- Associated members don't get a discount, so they always pay the full price.

5. Procedure Simple_Test (from the Online_Store.Tests package) is used for testing.

1. Based on a list of members that bought on the online store and the corresponding full price of the item, Simple_Test must display information about each member and the actual due amount after discounts.

2. Information about the members must be displayed in the following format:

Member # <number>

Status: <status>

Since:  <year>

Due Amount:  <value>

--------

3. For this exercise, Simple_Test must use the following list:

#

Membership status

Start (year)

Discount

Full Price

1

Associate

2010

N/A

250.00

2

Full

1998

10.0 %

160.00

3

Full

1987

20.0 %

400.00

4

Associate

2013

N/A

110.00

4. In order to pass the tests, the information displayed by a call to Simple_Test must conform to the format described above.

- You can find another example in the remarks below.

Remarks:

1. In previous labs, we could have implemented a simplified version of the system described above by simply using an enumeration type to specify the membership status. For example:

type Member_Status is (Associate_Member, Full_Member);

1. In this case, the Get_Price function would then evaluate the membership status and adapt the item price — assuming a fixed discount rate for all full members. This could be the corresponding function declaration:

type Amount is delta 10.0**(-2) digits 10;

function Get_Price (M : Member_Status;

P : Amount) return Amount;

2. In this exercise, however, we'll use type extension to represent the membership status in our application.

2. For the procedure Simple_Test, let's consider the following list of members as an example:

#

Membership status

Start (year)

Discount

Full Price

1

Associate

2002

N/A

100.00

2

Full

2005

10.0 %

100.00

- For this list, the test procedure displays the following information (in this exact format):

Member # 1

Status: Associate Member

Since:  2002

Due Amount:  100.00

--------

Member # 2

Status: Full Member

Since:  2005

Due Amount:  90.00

--------

- Here, although both members had the same full price (as indicated by the last column), member #2 gets a reduced due amount of 90.00 because of the full membership status.

online_store.ads

1with Ada.Calendar; use Ada.Calendar;

2

3package Online_Store is

4

5   type Amount is delta 10.0**(-2) digits 10;

6

7   subtype Percentage is Amount range 0.0 .. 1.0;

8

9   --  Create declaration of Member type!

10   --

11   --  You can use Year_Number from Ada.Calendar for the membership

12   --  starting year.

13   --

14   type Member is null record;

15

16   function Get_Status (M : Member) return String;

17

18   function Get_Price (M : Member;

19                       P : Amount) return Amount;

20

21   --  Create declaration of Full_Member type!

22   --

23   --  Use the Percentage type for storing the membership discount.

24   --

25   type Full_Member is null record;

26

27   function Get_Status (M : Full_Member) return String;

28

29   function Get_Price (M : Full_Member;

30                       P : Amount) return Amount;

31

32end Online_Store;

online_store.adb

1package body Online_Store is

2

3   function Get_Status (M : Member) return String is

4     ("");

5

6   function Get_Status (M : Full_Member) return String is

7     ("");

8

9   function Get_Price (M : Member;

10                       P : Amount) return Amount is (0.0);

11

12   function Get_Price (M : Full_Member;

13                       P : Amount) return Amount is

14     (0.0);

15

16end Online_Store;

online_store-tests.ads

1package Online_Store.Tests is

2

3   procedure Simple_Test;

4

5end Online_Store.Tests;

online_store-tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Online_Store.Tests is

4

5   procedure Simple_Test is

6   begin

7      null;

8   end Simple_Test;

9

10end Online_Store.Tests;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Online_Store;       use Online_Store;

5with Online_Store.Tests; use Online_Store.Tests;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Type_Chk,

11      Unit_Test_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      function Result_Image (Result : Boolean) return String is

16        (if Result then "OK" else "not OK");

17

18   begin

19      case TC is

20      when Type_Chk =>

21         declare

22            AM : constant Member      := (Start    => 2002);

23            FM : constant Full_Member := (Start    => 1990,

24                                          Discount => 0.2);

25         begin

26            Put_Line ("Testing Status of Associate Member Type => "

27                      & Result_Image (AM.Get_Status = "Associate Member"));

28            Put_Line ("Testing Status of Full Member Type => "

29                      & Result_Image (FM.Get_Status = "Full Member"));

30            Put_Line ("Testing Discount of Associate Member Type => "

31                      & Result_Image (AM.Get_Price (100.0) = 100.0));

32            Put_Line ("Testing Discount of Full Member Type => "

33                      & Result_Image (FM.Get_Price (100.0) = 80.0));

34         end;

35         when Unit_Test_Chk =>

36            Simple_Test;

37      end case;

38   end Check;

39

40begin

41   if Argument_Count < 1 then

42      Put_Line ("ERROR: missing arguments! Exiting...");

43      return;

44   elsif Argument_Count > 1 then

45      Put_Line ("Ignoring additional arguments...");

46   end if;

47

48   Check (Test_Case_Index'Value (Argument (1)));

49end Main;

Footnotes

Privacy

Directions

Goal: create a package that handles directions and geometric angles using a previous implementation.

Steps:

1. Fix the implementation of the Test_Directions procedure.

Requirements:

1. The implementation of the Test_Directions procedure must compile correctly.

Remarks:

1. This exercise is based on the Directions exercise from the Records labs.

1. In this version, however, Ext_Angle is a private type.

2. In the implementation of the Test_Directions procedure below, the Ada developer tried to initialize All_Directions — an array of Ext_Angle type — with aggregates.

1. Since we now have a private type, the compiler complains about this initialization.

3. To fix the implementation of the Test_Directions procedure, you should use the appropriate function from the Directions package.

4. The initialization of All_Directions in the code below contains a consistency error where the angle doesn't match the assessed direction.

1. See if you can spot this error!

2. This kind of errors can happen when record components that have correlated information are initialized individually without consistency checks — using private types helps to avoid the problem by requiring initialization routines that can enforce consistency.

directions.ads

1package Directions is

2

3   type Angle_Mod is mod 360;

4

5   type Direction is

6     (North,

7      Northwest,

8      West,

9      Southwest,

10      South,

11      Southeast,

12      East);

13

14   function To_Direction (N : Angle_Mod) return Direction;

15

16   type Ext_Angle is private;

17

18   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle;

19

20   procedure Display (N : Ext_Angle);

21

22private

23

24   type Ext_Angle is record

25      Angle_Elem     : Angle_Mod;

26      Direction_Elem : Direction;

27   end record;

28

29end Directions;

directions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Directions is

4

5   procedure Display (N : Ext_Angle) is

6   begin

7      Put_Line ("Angle: "

8                & Angle_Mod'Image (N.Angle_Elem)

9                & " => "

10                & Direction'Image (N.Direction_Elem)

11                & ".");

12   end Display;

13

14   function To_Direction (N : Angle_Mod) return Direction is

15   begin

16      case N is

17         when   0        => return East;

18         when   1 ..  89 => return Northwest;

19         when  90        => return North;

20         when  91 .. 179 => return Northwest;

21         when 180        => return West;

22         when 181 .. 269 => return Southwest;

23         when 270        => return South;

24         when 271 .. 359 => return Southeast;

25      end case;

26   end To_Direction;

27

28   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is

29   begin

30      return (Angle_Elem     => N,

31              Direction_Elem => To_Direction (N));

32   end To_Ext_Angle;

33

34end Directions;

test_directions.adb

1with Directions; use Directions;

2

3procedure Test_Directions is

4   type Ext_Angle_Array is array (Positive range <>) of Ext_Angle;

5

6   All_Directions : constant Ext_Angle_Array (1 .. 6)

7     := ((0,   East),

8         (45,  Northwest),

9         (90,  North),

10         (91,  North),

11         (180, West),

12         (270, South));

13

14begin

15   for I in All_Directions'Range loop

16      Display (All_Directions (I));

17   end loop;

18

19end Test_Directions;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Test_Directions;

5

6procedure Main is

7     type Test_Case_Index is

8     (Direction_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13      when Direction_Chk =>

14         Test_Directions;

15      end case;

16   end Check;

17

18begin

19   if Argument_Count < 1 then

20      Put_Line ("ERROR: missing arguments! Exiting...");

21      return;

22   elsif Argument_Count > 1 then

23      Put_Line ("Ignoring additional arguments...");

24   end if;

25

26   Check (Test_Case_Index'Value (Argument (1)));

27end Main;

Limited Strings

Goal: work with limited private types.

Steps:

1. Implement the Limited_Strings package.

1. Implement the Copy function.

2. Implement the = operator.

Requirements:

1. For both Copy and =, the two parameters may refer to strings with different lengths. We'll limit the implementation to just take the minimum length:

1. In case of copying the string "Hello World" to a string with 5 characters, the copied string is "Hello":

S1 : constant Lim_String := Init ("Hello World");

S2 :          Lim_String := Init (5);

begin

Copy (From => S1, To => S2);

Put_Line (S2);     --  This displays "Hello".

2. When comparing "Hello World" to "Hello", the = operator indicates that these strings are equivalent:

S1 : constant Lim_String := Init ("Hello World");

S2 : constant Lim_String := Init ("Hello");

begin

if S1 = S2 then

--  True => This branch gets selected.

2. When copying from a short string to a longer string, the remaining characters of the longer string must be initialized with underscores (_). For example:

S1 : constant Lim_String := Init ("Hello");

S2 :          Lim_String := Init (10);

begin

Copy (From => S1, To => S2);

Put_Line (S2);     --  This displays "Hello_____".

Remarks:

1. As we've discussed in the course:

1. Variables of limited types have the following limitations:

- they cannot be assigned to;

- they don't have an equality operator (=).

2. We can, however, define our own, custom subprograms to circumvent these limitations:

- In order to copy instances of a limited type, we can define a custom Copy procedure.

- In order to compare instances of a limited type, we can define an = operator.

2. You can use the Min_Last constant — which is already declared in the implementation of these subprograms — in the code you write.

3. Some details about the Limited_Strings package:

1. The Lim_String type acts as a container for strings.

1. In the the private part, Lim_String is declared as an access type to a String.

2. There are two versions of the Init function that initializes an object of Lim_String type:

1. The first one takes another string.

2. The second one receives the number of characters for a string container.

3. Procedure Put_Line displays object of Lim_String type.

4. The design and implementation of the Limited_Strings package is very simplistic.

1. A good design would have better handling of access types, for example.

limited_strings.ads

1package Limited_Strings is

2

3   type Lim_String is limited private;

4

5   function Init (S : String) return Lim_String;

6

7   function Init (Max : Positive) return Lim_String;

8

9   procedure Put_Line (LS : Lim_String);

10

11   procedure Copy (From :        Lim_String;

12                   To   : in out Lim_String);

13

14   function "=" (Ref, Dut : Lim_String) return Boolean;

15

16private

17

18   type Lim_String is access String;

19

20end Limited_Strings;

limited_strings.adb

1with Ada.Text_IO;

2

3package body Limited_Strings

4is

5

6   function Init (S : String) return Lim_String is

7      LS : constant Lim_String := new String'(S);

8   begin

9      return Ls;

10   end Init;

11

12   function Init (Max : Positive) return Lim_String is

13      LS : constant Lim_String := new String (1 .. Max);

14   begin

15      LS.all := (others => '_');

16      return LS;

17   end Init;

18

19   procedure Put_Line (LS : Lim_String) is

20   begin

21      Ada.Text_IO.Put_Line (LS.all);

22   end Put_Line;

23

24   function Get_Min_Last (A, B : Lim_String) return Positive is

25   begin

26      return Positive'Min (A'Last, B'Last);

27   end Get_Min_Last;

28

29   procedure Copy (From :        Lim_String;

30                   To   : in out Lim_String) is

31      Min_Last : constant Positive := Get_Min_Last (From, To);

32   begin

33      --  Complete the implementation!

34      null;

35   end;

36

37   function "=" (Ref, Dut : Lim_String) return Boolean is

38      Min_Last : constant Positive := Get_Min_Last (Ref, Dut);

39   begin

40      --  Complete the implementation!

41      return True;

42   end;

43

44end Limited_Strings;

check_lim_string.adb

1with Ada.Text_IO;     use Ada.Text_IO;

2

3with Limited_Strings; use Limited_Strings;

4

5procedure Check_Lim_String is

6   S  : constant String := "----------";

7   S1 : constant Lim_String := Init ("Hello World");

8   S2 : constant Lim_String := Init (30);

9   S3 : Lim_String := Init (5);

10   S4 : Lim_String := Init (S & S & S);

11begin

12   Put ("S1 => ");

13   Put_Line (S1);

14   Put ("S2 => ");

15   Put_Line (S2);

16

17   if S1 = S2 then

18      Put_Line ("S1 is equal to S2.");

19   else

20      Put_Line ("S1 isn't equal to S2.");

21   end if;

22

23   Copy (From => S1, To => S3);

24   Put ("S3 => ");

25   Put_Line (S3);

26

27   if S1 = S3 then

28      Put_Line ("S1 is equal to S3.");

29   else

30      Put_Line ("S1 isn't equal to S3.");

31   end if;

32

33   Copy (From => S1, To => S4);

34   Put ("S4 => ");

35   Put_Line (S4);

36

37   if S1 = S4 then

38      Put_Line ("S1 is equal to S4.");

39   else

40      Put_Line ("S1 isn't equal to S4.");

41   end if;

42end Check_Lim_String;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Check_Lim_String;

5

6procedure Main is

7   type Test_Case_Index is

8     (Lim_String_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13      when Lim_String_Chk =>

14         Check_Lim_String;

15      end case;

16   end Check;

17

18begin

19   if Argument_Count < 1 then

20      Put_Line ("ERROR: missing arguments! Exiting...");

21      return;

22   elsif Argument_Count > 1 then

23      Put_Line ("Ignoring additional arguments...");

24   end if;

25

26   Check (Test_Case_Index'Value (Argument (1)));

27end Main;

Bonus exercise

In previous labs, we had many source-code snippets containing records that could be declared private. The source-code for the exercise above (Directions) is an example: we've modified the type declaration of Ext_Angle, so that the record is now private. Encapsulating the record components — by declaring record components in the private part — makes the code safer. Also, because many of the code snippets weren't making use of record components directly (but handling record types via the API instead), they continue to work fine after these modifications.

This exercise doesn't contain any source-code. In fact, the goal here is to modify previous labs, so that the record declarations are made private. You can look into those labs, modify the type declarations, and recompile the code. The corresponding test-cases must still pass.

If no other changes are needed apart from changes in the declaration, then that indicates we have used good programming techniques in the original code. On the other hand, if further changes are needed, then you should investigate why this is the case.

Also note that, in some cases, you can move support types into the private part of the specification without affecting its compilation. This is the case, for example, for the People_Array type of the List of Names lab mentioned below. You should, in fact, keep only relevant types and subprograms in the public part and move all support declarations to the private part of the specification whenever possible.

Below, you find the selected labs that you can work on, including changes that you should make. In case you don't have a working version of the source-code of previous labs, you can look into the corresponding solutions.

Colors

Chapter: Records

Steps:

1. Change declaration of RGB type to private.

Requirements:

1. Implementation must compile correctly and test cases must pass.

List of Names

Chapter: Arrays

Steps:

1. Change declaration of Person and People types to limited private.

2. Move type declaration of People_Array to private part.

Requirements:

1. Implementation must compile correctly and test cases must pass.

Price List

Chapter: More About Types

Steps:

1. Change declaration of Price_List type to limited private.

Requirements:

1. Implementation must compile correctly and test cases must pass.

Footnotes

Records

Directions

Goal: create a package that handles directions and geometric angles.

Steps:

1. Implement the Directions package.

1. Declare the Ext_Angle record.

2. Implement the Display procedure.

3. Implement the To_Ext_Angle function.

Requirements:

1. Record Ext_Angle stores information about the extended angle (see remark about extended angles below).

2. Procedure Display displays information about the extended angle.

1. You should use the implementation that has been commented out (see code below) as a starting point.

3. Function To_Ext_Angle converts a simple angle value to an extended angle (Ext_Angle type).

Remarks:

1. We make use of the algorithm implemented in the Check_Direction procedure (chapter on imperative language).

2. For the sake of this exercise, we use the concept of extended angles. This includes the actual geometric angle and the corresponding direction (North, South, Northwest, and so on).

directions.ads

1package Directions is

2

3   type Angle_Mod is mod 360;

4

5   type Direction is

6     (North,

7      Northeast,

8      East,

9      Southeast,

10      South,

11      Southwest,

12      West,

13      Northwest);

14

15   function To_Direction (N: Angle_Mod) return Direction;

16

17   --  Include type declaration for Ext_Angle record type:

18   --

19   --  NOTE: Use the Angle_Mod and Direction types declared above!

20   --

21   --  type Ext_Angle is [...]

22   --

23

24   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle;

25

26   procedure Display (N : Ext_Angle);

27

28end Directions;

directions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Directions is

4

5   procedure Display (N : Ext_Angle) is

6   begin

7      --  Uncomment the code below and fill the missing elements

8      --

9      --  Put_Line ("Angle: "

10      --            & Angle_Mod'Image (____)

11      --            & " => "

12      --            & Direction'Image (____)

13      --            & ".");

14      null;

15   end Display;

16

17   function To_Direction (N : Angle_Mod) return Direction is

18   begin

19      case N is

20         when   0        => return North;

21         when   1 ..  89 => return Northeast;

22         when  90        => return East;

23         when  91 .. 179 => return Southeast;

24         when 180        => return South;

25         when 181 .. 269 => return Southwest;

26         when 270        => return West;

27         when 271 .. 359 => return Northwest;

28      end case;

29   end To_Direction;

30

31   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is

32   begin

33      --  Implement the conversion from Angle_Mod to Ext_Angle here!

34      --

35      --  Hint: you can use a return statement and an aggregate.

36      --

37      null;

38   end To_Ext_Angle;

39

40end Directions;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Directions;        use Directions;

5

6procedure Main is

7   type Test_Case_Index is

8     (Direction_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13      when Direction_Chk =>

14         Display (To_Ext_Angle (0));

15         Display (To_Ext_Angle (30));

16         Display (To_Ext_Angle (45));

17         Display (To_Ext_Angle (90));

18         Display (To_Ext_Angle (91));

19         Display (To_Ext_Angle (120));

20         Display (To_Ext_Angle (180));

21         Display (To_Ext_Angle (250));

22         Display (To_Ext_Angle (270));

23      end case;

24   end Check;

25

26begin

27   if Argument_Count < 1 then

28      Put_Line ("ERROR: missing arguments! Exiting...");

29      return;

30   elsif Argument_Count > 1 then

31      Put_Line ("Ignoring additional arguments...");

32   end if;

33

34   Check (Test_Case_Index'Value (Argument (1)));

35end Main;

Colors

Goal: create a package to represent HTML colors in RGB format using the hexadecimal form.

Steps:

1. Implement the Color_Types package.

1. Declare the RGB record.

2. Implement the To_RGB function.

3. Implement the Image function for the RGB type.

Requirements:

1. The following table contains the HTML colors and the corresponding value in hexadecimal form for each color element:

Color

Red

Green

Blue

Salmon

#FA

#80

#72

Firebrick

#B2

#22

#22

Red

#FF

#00

#00

Darkred

#8B

#00

#00

Lime

#00

#FF

#00

Forestgreen

#22

#8B

#22

Green

#00

#80

#00

Darkgreen

#00

#64

#00

Blue

#00

#00

#FF

Mediumblue

#00

#00

#CD

Darkblue

#00

#00

#8B

2. The hexadecimal information of each HTML color can be mapped to three color elements: red, green and blue.

1. Each color element has a value between 0 and 255, or 00 and FF in hexadecimal.

2. For example, for the color salmon, the hexadecimal value of the color elements are:

- red = FA,

- green = 80, and

- blue = 72.

3. Record RGB stores information about HTML colors in RGB format, so that we can retrieve the individual color elements.

4. Function To_RGB converts from the HTML_Color enumeration to the RGB type based on the information from the table above.

5. Function Image returns a string representation of the RGB type in this format:

- "(Red => 16#..#, Green => 16#...#, Blue => 16#...# )"

Remarks:

1. We use the exercise on HTML colors from the previous lab on Strongly typed language as a starting point.

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   function To_Integer (C : HTML_Color) return Integer;

17

18   type Basic_HTML_Color is

19     (Red,

20      Green,

21      Blue);

22

23   function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color;

24

25   subtype Int_Color is Integer range 0 .. 255;

26

27   --  Replace type declaration for RGB record below

28   --

29   --  - NOTE: Use the Int_Color type declared above!

30   --

31   --  type RGB is [...]

32   --

33   type RGB is null record;

34

35   function To_RGB (C : HTML_Color) return RGB;

36

37   function Image (C : RGB) return String;

38

39end Color_Types;

color_types.adb

1with Ada.Integer_Text_IO;

2

3package body Color_Types is

4

5   function To_Integer (C : HTML_Color) return Integer is

6   begin

7      case C is

8         when Salmon      => return 16#FA8072#;

9         when Firebrick   => return 16#B22222#;

10         when Red         => return 16#FF0000#;

11         when Darkred     => return 16#8B0000#;

12         when Lime        => return 16#00FF00#;

13         when Forestgreen => return 16#228B22#;

14         when Green       => return 16#008000#;

15         when Darkgreen   => return 16#006400#;

16         when Blue        => return 16#0000FF#;

17         when Mediumblue  => return 16#0000CD#;

18         when Darkblue    => return 16#00008B#;

19      end case;

20

21   end To_Integer;

22

23   function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color is

24   begin

25      case C is

26         when Red   => return Red;

27         when Green => return Green;

28         when Blue  => return Blue;

29      end case;

30   end To_HTML_Color;

31

32   function To_RGB (C : HTML_Color) return RGB is

33   begin

34      --  Implement the conversion from HTML_Color to RGB here!

35      --

36      return (null record);

37   end To_RGB;

38

39   function Image (C : RGB) return String is

40      subtype Str_Range is Integer range 1 .. 10;

41      SR : String (Str_Range);

42      SG : String (Str_Range);

43      SB : String (Str_Range);

44   begin

45      --  Replace argument in the calls to Put below

46      --  with the missing elements (red, green, blue)

47      --  from the RGB record

48      --

49      Ada.Integer_Text_IO.Put (To    => SR,

50                               Item  => 0,    --  REPLACE!

51                               Base  => 16);

52      Ada.Integer_Text_IO.Put (To    => SG,

53                               Item  => 0,    --  REPLACE!

54                               Base  => 16);

55      Ada.Integer_Text_IO.Put (To    => SB,

56                               Item  => 0,    --  REPLACE!

57                               Base  => 16);

58      return ("(Red => " & SR

59              & ", Green => " & SG

60              & ", Blue => "  & SB

61              &")");

62   end Image;

63

64end Color_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Color_Types;      use Color_Types;

5

6procedure Main is

7   type Test_Case_Index is

8     (HTML_Color_To_RGB);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13         when HTML_Color_To_RGB =>

14            for I in HTML_Color'Range loop

15               Put_Line (HTML_Color'Image (I) & " => "

16                         & Image (To_RGB (I)) & ".");

17            end loop;

18      end case;

19   end Check;

20

21begin

22   if Argument_Count < 1 then

23      Put_Line ("ERROR: missing arguments! Exiting...");

24      return;

25   elsif Argument_Count > 1 then

26      Put_Line ("Ignoring additional arguments...");

27   end if;

28

29   Check (Test_Case_Index'Value (Argument (1)));

30end Main;

Inventory

Goal: create a simplified inventory system for a store to enter items and keep track of assets.

Steps:

1. Implement the Inventory_Pkg package.

1. Declare the Item record.

2. Implement the Init function.

3. Implement the Add procedure.

Requirements:

1. Record Item collects information about products from the store.

1. To keep it simple, this record only contains the name, quantity and price of each item.

2. The record components are:

- Name of Item_Name type;

- Quantity of Natural type;

- Price of Float type.

2. Function Init returns an initialized item (of Item type).

1. Function Init must also display the item name by calling the To_String function for the Item_Name type.

- This is already implemented in the code below.

3. Procedure Add adds an item to the assets.

1. Since we want to keep track of the assets, the implementation must accumulate the total value of each item's inventory, the result of multiplying the item quantity and its price.

inventory_pkg.ads

1package Inventory_Pkg is

2

3   type Item_Name is

4     (Ballpoint_Pen, Oil_Based_Pen_Marker, Feather_Quill_Pen);

5

6   function To_String (I : Item_Name) return String;

7

8   --  Replace type declaration for Item record:

9   --

10   type Item is null record;

11

12   function Init (Name     : Item_Name;

13                  Quantity : Natural;

14                  Price    : Float) return Item;

15

16   procedure Add (Assets : in out Float;

17                  I      : Item);

18

19end Inventory_Pkg;

inventory_pkg.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Inventory_Pkg is

4

5   function To_String (I : Item_Name) return String is

6   begin

7      case I is

8         when Ballpoint_Pen        => return "Ballpoint Pen";

9         when Oil_Based_Pen_Marker => return "Oil-based Pen Marker";

10         when Feather_Quill_Pen    => return "Feather Quill Pen";

11      end case;

12   end To_String;

13

14   function Init (Name     : Item_Name;

15                  Quantity : Natural;

16                  Price    : Float) return Item is

17   begin

18      Put_Line ("Item: " & To_String (Name) & ".");

19

20      --  Replace return statement with the actual record initialization!

21      --

22      return (null record);

23   end Init;

24

25   procedure Add (Assets : in out Float;

26                  I      : Item) is

27   begin

28      --  Implement the function that adds an item to the inventory here!

29      --

30      null;

31   end Add;

32

33end Inventory_Pkg;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Inventory_Pkg;     use Inventory_Pkg;

5

6procedure Main is

7   --  Remark: the following line is not relevant.

8   F   : array (1 .. 10) of Float := (others => 42.42);

9

10   type Test_Case_Index is

11     (Inventory_Chk);

12

13   procedure Display (Assets : Float) is

14      package F_IO is new Ada.Text_IO.Float_IO (Float);

15

16      use F_IO;

17   begin

18      Put ("Assets: $");

19      Put (Assets, 1, 2, 0);

20      Put (".");

21      New_Line;

22   end Display;

23

24   procedure Check (TC : Test_Case_Index) is

25      I      : Item;

26      Assets : Float := 0.0;

27

28      --  Please ignore the following three lines!

29      pragma Warnings (Off, "default initialization");

30      for Assets'Address use F'Address;

31      pragma Warnings (On, "default initialization");

32   begin

33      case TC is

34      when Inventory_Chk =>

35         I := Init (Ballpoint_Pen,        185,  0.15);

36         Add (Assets, I);

37         Display (Assets);

38

39         I := Init (Oil_Based_Pen_Marker, 100,  9.0);

40         Add (Assets, I);

41         Display (Assets);

42

43         I := Init (Feather_Quill_Pen,      2, 40.0);

44         Add (Assets, I);

45         Display (Assets);

46      end case;

47   end Check;

48

49begin

50   if Argument_Count < 1 then

51      Put_Line ("ERROR: missing arguments! Exiting...");

52      return;

53   elsif Argument_Count > 1 then

54      Put_Line ("Ignoring additional arguments...");

55   end if;

56

57   Check (Test_Case_Index'Value (Argument (1)));

58end Main;

Footnotes

Solutions

Imperative Language

Hello World

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Main is

4begin

5   Put_Line ("Hello World!");

6end Main;

Greetings

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4procedure Main is

5

6   procedure Greet (Name : String) is

7   begin

8      Put_Line ("Hello " & Name & "!");

9   end Greet;

10

11begin

12   if Argument_Count < 1 then

13      Put_Line ("ERROR: missing arguments! Exiting...");

14      return;

15   elsif Argument_Count > 1 then

16      Put_Line ("Ignoring additional arguments...");

17   end if;

18

19   Greet (Argument (1));

20end Main;

Positive Or Negative

classify_number.ads

1procedure Classify_Number (X : Integer);

classify_number.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Classify_Number (X : Integer) is

4begin

5   if X > 0 then

6      Put_Line ("Positive");

7   elsif X < 0 then

8      Put_Line ("Negative");

9   else

10      Put_Line ("Zero");

11   end if;

12end Classify_Number;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Classify_Number;

5

6procedure Main is

7   A : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   A := Integer'Value (Argument (1));

17

18   Classify_Number (A);

19end Main;

Numbers

display_numbers.ads

1procedure Display_Numbers (A, B : Integer);

display_numbers.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Display_Numbers (A, B : Integer) is

4   X, Y : Integer;

5begin

6   if A <= B then

7      X := A;

8      Y := B;

9   else

10      X := B;

11      Y := A;

12   end if;

13

14   for I in X .. Y loop

15      Put_Line (Integer'Image (I));

16   end loop;

17end Display_Numbers;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_Numbers;

5

6procedure Main is

7   A, B : Integer;

8begin

9   if Argument_Count < 2 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 2 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   A := Integer'Value (Argument (1));

17   B := Integer'Value (Argument (2));

18

19   Display_Numbers (A, B);

20end Main;

Subprograms

Subtract Procedure

subtract.ads

1procedure Subtract (A, B   :     Integer;

2                       Result : out Integer);

subtract.adb

1procedure Subtract (A, B   :     Integer;

2                       Result : out Integer) is

3begin

4   Result := A - B;

5end Subtract;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Subtract;

5

6procedure Main is

7   type Test_Case_Index is

8     (Sub_10_1_Chk,

9      Sub_10_100_Chk,

10      Sub_0_5_Chk,

11      Sub_0_Minus_5_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14      Result : Integer;

15   begin

16      case TC is

17      when Sub_10_1_Chk =>

18         Subtract (10, 1, Result);

19         Put_Line ("Result: " & Integer'Image (Result));

20      when Sub_10_100_Chk =>

21         Subtract (10, 100, Result);

22         Put_Line ("Result: " & Integer'Image (Result));

23      when Sub_0_5_Chk =>

24         Subtract (0, 5, Result);

25         Put_Line ("Result: " & Integer'Image (Result));

26      when Sub_0_Minus_5_Chk =>

27         Subtract (0, -5, Result);

28         Put_Line ("Result: " & Integer'Image (Result));

29      end case;

30   end Check;

31

32begin

33   if Argument_Count < 1 then

34      Put_Line ("ERROR: missing arguments! Exiting...");

35      return;

36   elsif Argument_Count > 1 then

37      Put_Line ("Ignoring additional arguments...");

38   end if;

39

40   Check (Test_Case_Index'Value (Argument (1)));

41end Main;

Subtract Function

subtract.ads

1function Subtract (A, B : Integer) return Integer;

subtract.adb

1function Subtract (A, B : Integer) return Integer is

2begin

3   return A - B;

4end Subtract;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Subtract;

5

6procedure Main is

7   type Test_Case_Index is

8     (Sub_10_1_Chk,

9      Sub_10_100_Chk,

10      Sub_0_5_Chk,

11      Sub_0_Minus_5_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14      Result : Integer;

15   begin

16      case TC is

17      when Sub_10_1_Chk =>

18         Result := Subtract (10, 1);

19         Put_Line ("Result: " & Integer'Image (Result));

20      when Sub_10_100_Chk =>

21         Result := Subtract (10, 100);

22         Put_Line ("Result: " & Integer'Image (Result));

23      when Sub_0_5_Chk =>

24         Result := Subtract (0, 5);

25         Put_Line ("Result: " & Integer'Image (Result));

26      when Sub_0_Minus_5_Chk =>

27         Result := Subtract (0, -5);

28         Put_Line ("Result: " & Integer'Image (Result));

29      end case;

30   end Check;

31

32begin

33   if Argument_Count < 1 then

34      Put_Line ("ERROR: missing arguments! Exiting...");

35      return;

36   elsif Argument_Count > 1 then

37      Put_Line ("Ignoring additional arguments...");

38   end if;

39

40   Check (Test_Case_Index'Value (Argument (1)));

41end Main;

Equality function

is_equal.ads

1function Is_Equal (A, B : Integer) return Boolean;

is_equal.adb

1function Is_Equal (A, B : Integer) return Boolean is

2begin

3   return A = B;

4end Is_Equal;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Is_Equal;

5

6procedure Main is

7   type Test_Case_Index is

8     (Equal_Chk,

9      Inequal_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12

13      procedure Display_Equal (A, B  : Integer;

14                               Equal : Boolean) is

15      begin

16         Put (Integer'Image (A));

17         if Equal then

18            Put (" is equal to ");

19         else

20            Put (" isn't equal to ");

21         end if;

22         Put_Line (Integer'Image (B) & ".");

23      end Display_Equal;

24

25      Result : Boolean;

26   begin

27      case TC is

28      when Equal_Chk =>

29         for I in 0 .. 10 loop

30            Result := Is_Equal (I, I);

31            Display_Equal (I, I, Result);

32         end loop;

33      when Inequal_Chk =>

34         for I in 0 .. 10 loop

35            Result := Is_Equal (I, I - 1);

36            Display_Equal (I, I - 1, Result);

37         end loop;

38      end case;

39   end Check;

40

41begin

42   if Argument_Count < 1 then

43      Put_Line ("ERROR: missing arguments! Exiting...");

44      return;

45   elsif Argument_Count > 1 then

46      Put_Line ("Ignoring additional arguments...");

47   end if;

48

49   Check (Test_Case_Index'Value (Argument (1)));

50end Main;

States

display_state.ads

1procedure Display_State (State : Integer);

display_state.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Display_State (State : Integer) is

4begin

5   case State is

6      when 0 =>

7         Put_Line ("Off");

8      when 1 =>

9         Put_Line ("On: Simple Processing");

10      when 2 =>

11         Put_Line ("On: Advanced Processing");

12      when others =>

13         null;

14   end case;

15end Display_State;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_State;

5

6procedure Main is

7   State : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   State := Integer'Value (Argument (1));

17

18   Display_State (State);

19end Main;

States #2

get_state.ads

1function Get_State (State : Integer) return String;

get_state.adb

1function Get_State (State : Integer) return String is

2begin

3   return (case State is

4           when 0 => "Off",

5           when 1 => "On: Simple Processing",

6           when 2 => "On: Advanced Processing",

7           when others => "");

8end Get_State;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Get_State;

5

6procedure Main is

7   State : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   State := Integer'Value (Argument (1));

17

18   Put_Line (Get_State (State));

19end Main;

States #3

is_on.ads

1function Is_On (State : Integer) return Boolean;

is_on.adb

1function Is_On (State : Integer) return Boolean is

2begin

3   return not (State = 0);

4end Is_On;

display_on_off.ads

1procedure Display_On_Off (State : Integer);

display_on_off.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Is_On;

3

4procedure Display_On_Off (State : Integer) is

5begin

6   Put_Line (if Is_On (State) then "On" else "Off");

7end Display_On_Off;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_On_Off;

5with Is_On;

6

7procedure Main is

8   State : Integer;

9begin

10   if Argument_Count < 1 then

11      Put_Line ("ERROR: missing arguments! Exiting...");

12      return;

13   elsif Argument_Count > 1 then

14      Put_Line ("Ignoring additional arguments...");

15   end if;

16

17   State := Integer'Value (Argument (1));

18

19   Display_On_Off (State);

20   Put_Line (Boolean'Image (Is_On (State)));

21end Main;

States #4

set_next.ads

1procedure Set_Next (State : in out Integer);

set_next.adb

1procedure Set_Next (State : in out Integer) is

2begin

3   State := (if State < 2 then State + 1 else 0);

4end Set_Next;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Set_Next;

5

6procedure Main is

7   State : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   State := Integer'Value (Argument (1));

17

18   Set_Next (State);

19   Put_Line (Integer'Image (State));

20end Main;

Modular Programming

Months

months.ads

1package Months is

2

3   Jan : constant String := "January";

4   Feb : constant String := "February";

5   Mar : constant String := "March";

6   Apr : constant String := "April";

7   May : constant String := "May";

8   Jun : constant String := "June";

9   Jul : constant String := "July";

10   Aug : constant String := "August";

11   Sep : constant String := "September";

12   Oct : constant String := "October";

13   Nov : constant String := "November";

14   Dec : constant String := "December";

15

16   procedure Display_Months;

17

18end Months;

months.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Months is

4

5   procedure Display_Months is

6   begin

7      Put_Line ("Months:");

8      Put_Line ("- " & Jan);

9      Put_Line ("- " & Feb);

10      Put_Line ("- " & Mar);

11      Put_Line ("- " & Apr);

12      Put_Line ("- " & May);

13      Put_Line ("- " & Jun);

14      Put_Line ("- " & Jul);

15      Put_Line ("- " & Aug);

16      Put_Line ("- " & Sep);

17      Put_Line ("- " & Oct);

18      Put_Line ("- " & Nov);

19      Put_Line ("- " & Dec);

20   end Display_Months;

21

22end Months;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Months;           use Months;

5

6procedure Main is

7

8   type Test_Case_Index is

9     (Months_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12   begin

13      case TC is

14         when Months_Chk =>

15            Display_Months;

16      end case;

17   end Check;

18

19begin

20   if Argument_Count < 1 then

21      Put_Line ("ERROR: missing arguments! Exiting...");

22      return;

23   elsif Argument_Count > 1 then

24      Put_Line ("Ignoring additional arguments...");

25   end if;

26

27   Check (Test_Case_Index'Value (Argument (1)));

28end Main;

Operations

operations.ads

1package Operations is

2

3   function Add (A, B : Integer) return Integer;

4

5   function Subtract (A, B : Integer) return Integer;

6

7   function Multiply (A, B : Integer) return Integer;

8

9   function Divide (A, B : Integer) return Integer;

10

11end Operations;

operations.adb

1package body Operations is

2

3   function Add (A, B : Integer) return Integer is

4   begin

5      return A + B;

6   end Add;

7

8   function Subtract (A, B : Integer) return Integer is

9   begin

10      return A - B;

11   end Subtract;

12

13   function Multiply (A, B : Integer) return Integer is

14   begin

15      return A * B;

16   end Multiply;

17

18   function Divide (A, B : Integer) return Integer is

19   begin

20      return A / B;

21   end Divide;

22

23end Operations;

operations-test.ads

1package Operations.Test is

2

3   procedure Display (A, B : Integer);

4

5end Operations.Test;

operations-test.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Operations.Test is

4

5   procedure Display (A, B : Integer) is

6      A_Str : constant String := Integer'Image (A);

7      B_Str : constant String := Integer'Image (B);

8   begin

9      Put_Line ("Operations:");

10      Put_Line (A_Str & " + " & B_Str & " = "

11                & Integer'Image (Add (A, B))

12                & ",");

13      Put_Line (A_Str & " - " & B_Str & " = "

14                & Integer'Image (Subtract (A, B))

15                & ",");

16      Put_Line (A_Str & " * " & B_Str & " = "

17                & Integer'Image (Multiply (A, B))

18                & ",");

19      Put_Line (A_Str & " / " & B_Str & " = "

20                & Integer'Image (Divide (A, B))

21                & ",");

22   end Display;

23

24end Operations.Test;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Operations;

5with Operations.Test;  use Operations.Test;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Operations_Chk,

11      Operations_Display_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14   begin

15      case TC is

16         when Operations_Chk =>

17            Put_Line ("Add (100, 2) = "

18                      & Integer'Image (Operations.Add (100, 2)));

19            Put_Line ("Subtract (100, 2) = "

20                      & Integer'Image (Operations.Subtract (100, 2)));

21            Put_Line ("Multiply (100, 2) = "

22                      & Integer'Image (Operations.Multiply (100, 2)));

23            Put_Line ("Divide (100, 2) = "

24                      & Integer'Image (Operations.Divide (100, 2)));

25         when Operations_Display_Chk =>

26            Display (10, 5);

27            Display ( 1, 2);

28      end case;

29   end Check;

30

31begin

32   if Argument_Count < 1 then

33      Put_Line ("ERROR: missing arguments! Exiting...");

34      return;

35   elsif Argument_Count > 1 then

36      Put_Line ("Ignoring additional arguments...");

37   end if;

38

39   Check (Test_Case_Index'Value (Argument (1)));

40end Main;

Strongly typed language

Colors

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   function To_Integer (C : HTML_Color) return Integer;

17

18   type Basic_HTML_Color is

19     (Red,

20      Green,

21      Blue);

22

23   function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color;

24

25end Color_Types;

color_types.adb

1package body Color_Types is

2

3   function To_Integer (C : HTML_Color) return Integer is

4   begin

5      case C is

6         when Salmon      => return 16#FA8072#;

7         when Firebrick   => return 16#B22222#;

8         when Red         => return 16#FF0000#;

9         when Darkred     => return 16#8B0000#;

10         when Lime        => return 16#00FF00#;

11         when Forestgreen => return 16#228B22#;

12         when Green       => return 16#008000#;

13         when Darkgreen   => return 16#006400#;

14         when Blue        => return 16#0000FF#;

15         when Mediumblue  => return 16#0000CD#;

16         when Darkblue    => return 16#00008B#;

17      end case;

18

19   end To_Integer;

20

21   function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color is

22   begin

23      case C is

24         when Red   => return Red;

25         when Green => return Green;

26         when Blue  => return Blue;

27      end case;

28   end To_HTML_Color;

29

30end Color_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Integer_Text_IO;

4

5with Color_Types;       use Color_Types;

6

7procedure Main is

8   type Test_Case_Index is

9     (HTML_Color_Range,

10      HTML_Color_To_Integer,

11      Basic_HTML_Color_To_HTML_Color);

12

13   procedure Check (TC : Test_Case_Index) is

14   begin

15      case TC is

16         when HTML_Color_Range =>

17            for I in HTML_Color'Range loop

18               Put_Line (HTML_Color'Image (I));

19            end loop;

20         when HTML_Color_To_Integer =>

21            for I in HTML_Color'Range loop

22               Ada.Integer_Text_IO.Put (Item  => To_Integer (I),

23                                        Width => 1,

24                                        Base  => 16);

25               New_Line;

26            end loop;

27         when Basic_HTML_Color_To_HTML_Color =>

28            for I in Basic_HTML_Color'Range loop

29               Put_Line (HTML_Color'Image (To_HTML_Color (I)));

30            end loop;

31      end case;

32   end Check;

33

34begin

35   if Argument_Count < 1 then

36      Put_Line ("ERROR: missing arguments! Exiting...");

37      return;

38   elsif Argument_Count > 1 then

39      Put_Line ("Ignoring additional arguments...");

40   end if;

41

42   Check (Test_Case_Index'Value (Argument (1)));

43end Main;

Integers

int_types.ads

1package Int_Types is

2

3   type I_100 is range 0 .. 100;

4

5   type U_100 is mod 101;

6

7   function To_I_100 (V : U_100) return I_100;

8

9   function To_U_100 (V : I_100) return U_100;

10

11   type D_50 is new I_100 range 10 .. 50;

12

13   subtype S_50 is I_100 range 10 .. 50;

14

15   function To_D_50 (V : I_100) return D_50;

16

17   function To_S_50 (V : I_100) return S_50;

18

19   function To_I_100 (V : D_50) return I_100;

20

21end Int_Types;

int_types.adb

1package body Int_Types is

2

3   function To_I_100 (V : U_100) return I_100 is

4   begin

5      return I_100 (V);

6   end To_I_100;

7

8   function To_U_100 (V : I_100) return U_100 is

9   begin

10      return U_100 (V);

11   end To_U_100;

12

13   function To_D_50 (V : I_100) return D_50 is

14      Min : constant I_100 := I_100 (D_50'First);

15      Max : constant I_100 := I_100 (D_50'Last);

16   begin

17      if V > Max then

18         return D_50'Last;

19      elsif V < Min then

20         return D_50'First;

21      else

22         return D_50 (V);

23      end if;

24   end To_D_50;

25

26   function To_S_50 (V : I_100) return S_50 is

27   begin

28      if V > S_50'Last then

29         return S_50'Last;

30      elsif V < S_50'First then

31         return S_50'First;

32      else

33         return V;

34      end if;

35   end To_S_50;

36

37   function To_I_100 (V : D_50) return I_100 is

38   begin

39      return I_100 (V);

40   end To_I_100;

41

42end Int_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Int_Types;        use Int_Types;

5

6procedure Main is

7   package I_100_IO is new Ada.Text_IO.Integer_IO (I_100);

8   package U_100_IO is new Ada.Text_IO.Modular_IO (U_100);

9   package D_50_IO  is new Ada.Text_IO.Integer_IO (D_50);

10

11   use I_100_IO;

12   use U_100_IO;

13   use D_50_IO;

14

15   type Test_Case_Index is

16     (I_100_Range,

17      U_100_Range,

18      U_100_Wraparound,

19      U_100_To_I_100,

20      I_100_To_U_100,

21      D_50_Range,

22      S_50_Range,

23      I_100_To_D_50,

24      I_100_To_S_50,

25      D_50_To_I_100,

26      S_50_To_I_100);

27

28   procedure Check (TC : Test_Case_Index) is

29   begin

30      I_100_IO.Default_Width := 1;

31      U_100_IO.Default_Width := 1;

32      D_50_IO.Default_Width  := 1;

33

34      case TC is

35         when I_100_Range =>

36            Put (I_100'First);

37            New_Line;

38            Put (I_100'Last);

39            New_Line;

40         when U_100_Range =>

41            Put (U_100'First);

42            New_Line;

43            Put (U_100'Last);

44            New_Line;

45         when U_100_Wraparound =>

46            Put (U_100'First - 1);

47            New_Line;

48            Put (U_100'Last + 1);

49            New_Line;

50         when U_100_To_I_100 =>

51            for I in U_100'Range loop

52               I_100_IO.Put (To_I_100 (I));

53               New_Line;

54            end loop;

55         when I_100_To_U_100 =>

56            for I in I_100'Range loop

57               Put (To_U_100 (I));

58               New_Line;

59            end loop;

60         when D_50_Range =>

61            Put (D_50'First);

62            New_Line;

63            Put (D_50'Last);

64            New_Line;

65         when S_50_Range =>

66            Put (S_50'First);

67            New_Line;

68            Put (S_50'Last);

69            New_Line;

70         when I_100_To_D_50 =>

71            for I in I_100'Range loop

72               Put (To_D_50 (I));

73               New_Line;

74            end loop;

75         when I_100_To_S_50 =>

76            for I in I_100'Range loop

77               Put (To_S_50 (I));

78               New_Line;

79            end loop;

80         when D_50_To_I_100 =>

81            for I in D_50'Range loop

82               Put (To_I_100 (I));

83               New_Line;

84            end loop;

85         when S_50_To_I_100 =>

86            for I in S_50'Range loop

87               Put (I);

88               New_Line;

89            end loop;

90      end case;

91   end Check;

92

93begin

94   if Argument_Count < 1 then

95      Put_Line ("ERROR: missing arguments! Exiting...");

96      return;

97   elsif Argument_Count > 1 then

98      Put_Line ("Ignoring additional arguments...");

99   end if;

100

101   Check (Test_Case_Index'Value (Argument (1)));

102end Main;

Temperatures

temperature_types.ads

1package Temperature_Types is

2

3   type Celsius is digits 6 range -273.15 .. 5504.85;

4

5   type Int_Celsius is range -273 .. 5505;

6

7   function To_Celsius (T : Int_Celsius) return Celsius;

8

9   function To_Int_Celsius (T : Celsius) return Int_Celsius;

10

11   type Kelvin is digits 6 range 0.0 .. 5778.00;

12

13   function To_Celsius (T : Kelvin) return Celsius;

14

15   function To_Kelvin (T : Celsius) return Kelvin;

16

17end Temperature_Types;

temperature_types.adb

1package body Temperature_Types is

2

3   function To_Celsius (T : Int_Celsius) return Celsius is

4      Min : constant Float := Float (Celsius'First);

5      Max : constant Float := Float (Celsius'Last);

6

7      F   : constant Float := Float (T);

8   begin

9      if F > Max then

10         return Celsius (Max);

11      elsif F < Min then

12         return Celsius (Min);

13      else

14         return Celsius (F);

15      end if;

16   end To_Celsius;

17

18   function To_Int_Celsius (T : Celsius) return Int_Celsius is

19   begin

20      return Int_Celsius (T);

21   end To_Int_Celsius;

22

23   function To_Celsius (T : Kelvin) return Celsius is

24      F : constant Float := Float (T);

25   begin

26      return Celsius (F - 273.15);

27   end To_Celsius;

28

29   function To_Kelvin (T : Celsius) return Kelvin is

30      F : constant Float := Float (T);

31   begin

32      return Kelvin (F + 273.15);

33   end To_Kelvin;

34

35end Temperature_Types;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Temperature_Types; use Temperature_Types;

5

6procedure Main is

7   package Celsius_IO     is new Ada.Text_IO.Float_IO (Celsius);

8   package Kelvin_IO      is new Ada.Text_IO.Float_IO (Kelvin);

9   package Int_Celsius_IO is new Ada.Text_IO.Integer_IO (Int_Celsius);

10

11   use Celsius_IO;

12   use Kelvin_IO;

13   use Int_Celsius_IO;

14

15   type Test_Case_Index is

16     (Celsius_Range,

17      Celsius_To_Int_Celsius,

18      Int_Celsius_To_Celsius,

19      Kelvin_To_Celsius,

20      Celsius_To_Kelvin);

21

22   procedure Check (TC : Test_Case_Index) is

23   begin

24      Celsius_IO.Default_Fore := 1;

25      Kelvin_IO.Default_Fore  := 1;

26      Int_Celsius_IO.Default_Width := 1;

27

28      case TC is

29         when Celsius_Range =>

30            Put (Celsius'First);

31            New_Line;

32            Put (Celsius'Last);

33            New_Line;

34         when Celsius_To_Int_Celsius =>

35            Put (To_Int_Celsius (Celsius'First));

36            New_Line;

37            Put (To_Int_Celsius (0.0));

38            New_Line;

39            Put (To_Int_Celsius (Celsius'Last));

40            New_Line;

41         when Int_Celsius_To_Celsius =>

42            Put (To_Celsius (Int_Celsius'First));

43            New_Line;

44            Put (To_Celsius (0));

45            New_Line;

46            Put (To_Celsius (Int_Celsius'Last));

47            New_Line;

48         when Kelvin_To_Celsius =>

49            Put (To_Celsius (Kelvin'First));

50            New_Line;

51            Put (To_Celsius (0));

52            New_Line;

53            Put (To_Celsius (Kelvin'Last));

54            New_Line;

55         when Celsius_To_Kelvin =>

56            Put (To_Kelvin (Celsius'First));

57            New_Line;

58            Put (To_Kelvin (Celsius'Last));

59            New_Line;

60      end case;

61   end Check;

62

63begin

64   if Argument_Count < 1 then

65      Put_Line ("ERROR: missing arguments! Exiting...");

66      return;

67   elsif Argument_Count > 1 then

68      Put_Line ("Ignoring additional arguments...");

69   end if;

70

71   Check (Test_Case_Index'Value (Argument (1)));

72end Main;

Records

Directions

directions.ads

1package Directions is

2

3   type Angle_Mod is mod 360;

4

5   type Direction is

6     (North,

7      Northeast,

8      East,

9      Southeast,

10      South,

11      Southwest,

12      West,

13      Northwest);

14

15   function To_Direction (N: Angle_Mod) return Direction;

16

17   type Ext_Angle is record

18      Angle_Elem     : Angle_Mod;

19      Direction_Elem : Direction;

20   end record;

21

22   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle;

23

24   procedure Display (N : Ext_Angle);

25

26end Directions;

directions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Directions is

4

5   procedure Display (N : Ext_Angle) is

6   begin

7      Put_Line ("Angle: "

8                & Angle_Mod'Image (N.Angle_Elem)

9                & " => "

10                & Direction'Image (N.Direction_Elem)

11                & ".");

12   end Display;

13

14   function To_Direction (N : Angle_Mod) return Direction is

15   begin

16      case N is

17         when   0        => return North;

18         when   1 ..  89 => return Northeast;

19         when  90        => return East;

20         when  91 .. 179 => return Southeast;

21         when 180        => return South;

22         when 181 .. 269 => return Southwest;

23         when 270        => return West;

24         when 271 .. 359 => return Northwest;

25      end case;

26   end To_Direction;

27

28   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is

29   begin

30      return (Angle_Elem     => N,

31              Direction_Elem => To_Direction (N));

32   end To_Ext_Angle;

33

34end Directions;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Directions;        use Directions;

5

6procedure Main is

7   type Test_Case_Index is

8     (Direction_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13      when Direction_Chk =>

14         Display (To_Ext_Angle (0));

15         Display (To_Ext_Angle (30));

16         Display (To_Ext_Angle (45));

17         Display (To_Ext_Angle (90));

18         Display (To_Ext_Angle (91));

19         Display (To_Ext_Angle (120));

20         Display (To_Ext_Angle (180));

21         Display (To_Ext_Angle (250));

22         Display (To_Ext_Angle (270));

23      end case;

24   end Check;

25

26begin

27   if Argument_Count < 1 then

28      Put_Line ("ERROR: missing arguments! Exiting...");

29      return;

30   elsif Argument_Count > 1 then

31      Put_Line ("Ignoring additional arguments...");

32   end if;

33

34   Check (Test_Case_Index'Value (Argument (1)));

35end Main;

Colors

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   function To_Integer (C : HTML_Color) return Integer;

17

18   type Basic_HTML_Color is

19     (Red,

20      Green,

21      Blue);

22

23   function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color;

24

25   subtype Int_Color is Integer range 0 .. 255;

26

27   type RGB is record

28      Red   : Int_Color;

29      Green : Int_Color;

30      Blue  : Int_Color;

31   end record;

32

33   function To_RGB (C : HTML_Color) return RGB;

34

35   function Image (C : RGB) return String;

36

37end Color_Types;

color_types.adb

1with Ada.Integer_Text_IO;

2

3package body Color_Types is

4

5   function To_Integer (C : HTML_Color) return Integer is

6   begin

7      case C is

8         when Salmon      => return 16#FA8072#;

9         when Firebrick   => return 16#B22222#;

10         when Red         => return 16#FF0000#;

11         when Darkred     => return 16#8B0000#;

12         when Lime        => return 16#00FF00#;

13         when Forestgreen => return 16#228B22#;

14         when Green       => return 16#008000#;

15         when Darkgreen   => return 16#006400#;

16         when Blue        => return 16#0000FF#;

17         when Mediumblue  => return 16#0000CD#;

18         when Darkblue    => return 16#00008B#;

19      end case;

20

21   end To_Integer;

22

23   function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color is

24   begin

25      case C is

26         when Red   => return Red;

27         when Green => return Green;

28         when Blue  => return Blue;

29      end case;

30   end To_HTML_Color;

31

32   function To_RGB (C : HTML_Color) return RGB is

33   begin

34      case C is

35         when Salmon      => return (16#FA#, 16#80#, 16#72#);

36         when Firebrick   => return (16#B2#, 16#22#, 16#22#);

37         when Red         => return (16#FF#, 16#00#, 16#00#);

38         when Darkred     => return (16#8B#, 16#00#, 16#00#);

39         when Lime        => return (16#00#, 16#FF#, 16#00#);

40         when Forestgreen => return (16#22#, 16#8B#, 16#22#);

41         when Green       => return (16#00#, 16#80#, 16#00#);

42         when Darkgreen   => return (16#00#, 16#64#, 16#00#);

43         when Blue        => return (16#00#, 16#00#, 16#FF#);

44         when Mediumblue  => return (16#00#, 16#00#, 16#CD#);

45         when Darkblue    => return (16#00#, 16#00#, 16#8B#);

46      end case;

47

48   end To_RGB;

49

50   function Image (C : RGB) return String is

51      subtype Str_Range is Integer range 1 .. 10;

52      SR : String (Str_Range);

53      SG : String (Str_Range);

54      SB : String (Str_Range);

55   begin

56      Ada.Integer_Text_IO.Put (To    => SR,

57                               Item  => C.Red,

58                               Base  => 16);

59      Ada.Integer_Text_IO.Put (To    => SG,

60                               Item  => C.Green,

61                               Base  => 16);

62      Ada.Integer_Text_IO.Put (To    => SB,

63                               Item  => C.Blue,

64                               Base  => 16);

65      return ("(Red => " & SR

66              & ", Green => " & SG

67              & ", Blue => "  & SB

68              &")");

69   end Image;

70

71end Color_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Color_Types;      use Color_Types;

5

6procedure Main is

7   type Test_Case_Index is

8     (HTML_Color_To_RGB);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13         when HTML_Color_To_RGB =>

14            for I in HTML_Color'Range loop

15               Put_Line (HTML_Color'Image (I) & " => "

16                         & Image (To_RGB (I)) & ".");

17            end loop;

18      end case;

19   end Check;

20

21begin

22   if Argument_Count < 1 then

23      Put_Line ("ERROR: missing arguments! Exiting...");

24      return;

25   elsif Argument_Count > 1 then

26      Put_Line ("Ignoring additional arguments...");

27   end if;

28

29   Check (Test_Case_Index'Value (Argument (1)));

30end Main;

Inventory

inventory_pkg.ads

1package Inventory_Pkg is

2

3   type Item_Name is

4     (Ballpoint_Pen, Oil_Based_Pen_Marker, Feather_Quill_Pen);

5

6   function To_String (I : Item_Name) return String;

7

8   type Item is record

9      Name     : Item_Name;

10      Quantity : Natural;

11      Price    : Float;

12   end record;

13

14   function Init (Name     : Item_Name;

15                  Quantity : Natural;

16                  Price    : Float) return Item;

17

18   procedure Add (Assets : in out Float;

19                  I      : Item);

20

21end Inventory_Pkg;

inventory_pkg.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Inventory_Pkg is

4

5   function To_String (I : Item_Name) return String is

6   begin

7      case I is

8         when Ballpoint_Pen        => return "Ballpoint Pen";

9         when Oil_Based_Pen_Marker => return "Oil-based Pen Marker";

10         when Feather_Quill_Pen    => return "Feather Quill Pen";

11      end case;

12   end To_String;

13

14   function Init (Name     : Item_Name;

15                  Quantity : Natural;

16                  Price    : Float) return Item is

17   begin

18      Put_Line ("Item: " & To_String (Name) & ".");

19

20      return (Name     => Name,

21              Quantity => Quantity,

22              Price    => Price);

23   end Init;

24

25   procedure Add (Assets : in out Float;

26                  I      : Item) is

27   begin

28      Assets := Assets + Float (I.Quantity) * I.Price;

29   end Add;

30

31end Inventory_Pkg;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Inventory_Pkg;     use Inventory_Pkg;

5

6procedure Main is

7   --  Remark: the following line is not relevant.

8   F   : array (1 .. 10) of Float := (others => 42.42);

9

10   type Test_Case_Index is

11     (Inventory_Chk);

12

13   procedure Display (Assets : Float) is

14      package F_IO is new Ada.Text_IO.Float_IO (Float);

15

16      use F_IO;

17   begin

18      Put ("Assets: $");

19      Put (Assets, 1, 2, 0);

20      Put (".");

21      New_Line;

22   end Display;

23

24   procedure Check (TC : Test_Case_Index) is

25      I      : Item;

26      Assets : Float := 0.0;

27

28      --  Please ignore the following three lines!

29      pragma Warnings (Off, "default initialization");

30      for Assets'Address use F'Address;

31      pragma Warnings (On, "default initialization");

32   begin

33      case TC is

34      when Inventory_Chk =>

35         I := Init (Ballpoint_Pen,        185,  0.15);

36         Add (Assets, I);

37         Display (Assets);

38

39         I := Init (Oil_Based_Pen_Marker, 100,  9.0);

40         Add (Assets, I);

41         Display (Assets);

42

43         I := Init (Feather_Quill_Pen,      2, 40.0);

44         Add (Assets, I);

45         Display (Assets);

46      end case;

47   end Check;

48

49begin

50   if Argument_Count < 1 then

51      Put_Line ("ERROR: missing arguments! Exiting...");

52      return;

53   elsif Argument_Count > 1 then

54      Put_Line ("Ignoring additional arguments...");

55   end if;

56

57   Check (Test_Case_Index'Value (Argument (1)));

58end Main;

Arrays

Constrained Array

constrained_arrays.ads

1package Constrained_Arrays is

2

3   type My_Index is range 1 .. 10;

4

5   type My_Array is array (My_Index) of Integer;

6

7   function Init return My_Array;

8

9   procedure Double (A : in out My_Array);

10

11   function First_Elem (A : My_Array) return Integer;

12

13   function Last_Elem (A : My_Array) return Integer;

14

15   function Length (A : My_Array) return Integer;

16

17   A : My_Array := (1, 2, others => 42);

18

19end Constrained_Arrays;

constrained_arrays.adb

1package body Constrained_Arrays is

2

3   function Init return My_Array is

4      A : My_Array;

5   begin

6      for I in My_Array'Range loop

7         A (I) := Integer (I);

8      end loop;

9

10      return A;

11   end Init;

12

13   procedure Double (A : in out My_Array) is

14   begin

15      for I in A'Range loop

16         A (I) := A (I) * 2;

17      end loop;

18   end Double;

19

20   function First_Elem (A : My_Array) return Integer is

21   begin

22      return A (A'First);

23   end First_Elem;

24

25   function Last_Elem (A : My_Array) return Integer is

26   begin

27      return A (A'Last);

28   end Last_Elem;

29

30   function Length (A : My_Array) return Integer is

31   begin

32      return A'Length;

33   end Length;

34

35end Constrained_Arrays;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Constrained_Arrays; use Constrained_Arrays;

5

6procedure Main is

7   type Test_Case_Index is

8     (Range_Chk,

9      Array_Range_Chk,

10      A_Obj_Chk,

11      Init_Chk,

12      Double_Chk,

13      First_Elem_Chk,

14      Last_Elem_Chk,

15      Length_Chk);

16

17   procedure Check (TC : Test_Case_Index) is

18      AA : My_Array;

19

20      procedure Display (A : My_Array) is

21      begin

22         for I in A'Range loop

23            Put_Line (Integer'Image (A (I)));

24         end loop;

25      end Display;

26

27      procedure Local_Init (A : in out My_Array) is

28      begin

29         A := (100, 90, 80, 10, 20, 30, 40, 60, 50, 70);

30      end Local_Init;

31   begin

32      case TC is

33      when Range_Chk =>

34         for I in My_Index loop

35            Put_Line (My_Index'Image (I));

36         end loop;

37      when Array_Range_Chk =>

38         for I in My_Array'Range loop

39            Put_Line (My_Index'Image (I));

40         end loop;

41      when A_Obj_Chk =>

42         Display (A);

43      when Init_Chk =>

44         AA := Init;

45         Display (AA);

46      when Double_Chk =>

47         Local_Init (AA);

48         Double (AA);

49         Display (AA);

50      when First_Elem_Chk =>

51         Local_Init (AA);

52         Put_Line (Integer'Image (First_Elem (AA)));

53      when Last_Elem_Chk =>

54         Local_Init (AA);

55         Put_Line (Integer'Image (Last_Elem (AA)));

56      when Length_Chk =>

57         Put_Line (Integer'Image (Length (AA)));

58      end case;

59   end Check;

60

61begin

62   if Argument_Count < 1 then

63      Put_Line ("ERROR: missing arguments! Exiting...");

64      return;

65   elsif Argument_Count > 1 then

66      Put_Line ("Ignoring additional arguments...");

67   end if;

68

69   Check (Test_Case_Index'Value (Argument (1)));

70end Main;

Colors: Lookup-Table

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   subtype Int_Color is Integer range 0 .. 255;

17

18   type RGB is record

19      Red   : Int_Color;

20      Green : Int_Color;

21      Blue  : Int_Color;

22   end record;

23

24   function To_RGB (C : HTML_Color) return RGB;

25

26   function Image (C : RGB) return String;

27

28   type HTML_Color_RGB is array (HTML_Color) of RGB;

29

30   To_RGB_Lookup_Table : constant HTML_Color_RGB

31     := (Salmon      => (16#FA#, 16#80#, 16#72#),

32         Firebrick   => (16#B2#, 16#22#, 16#22#),

33         Red         => (16#FF#, 16#00#, 16#00#),

34         Darkred     => (16#8B#, 16#00#, 16#00#),

35         Lime        => (16#00#, 16#FF#, 16#00#),

36         Forestgreen => (16#22#, 16#8B#, 16#22#),

37         Green       => (16#00#, 16#80#, 16#00#),

38         Darkgreen   => (16#00#, 16#64#, 16#00#),

39         Blue        => (16#00#, 16#00#, 16#FF#),

40         Mediumblue  => (16#00#, 16#00#, 16#CD#),

41         Darkblue    => (16#00#, 16#00#, 16#8B#));

42

43end Color_Types;

color_types.adb

1with Ada.Integer_Text_IO;

2package body Color_Types is

3

4   function To_RGB (C : HTML_Color) return RGB is

5   begin

6      return To_RGB_Lookup_Table (C);

7   end To_RGB;

8

9   function Image (C : RGB) return String is

10      subtype Str_Range is Integer range 1 .. 10;

11      SR : String (Str_Range);

12      SG : String (Str_Range);

13      SB : String (Str_Range);

14   begin

15      Ada.Integer_Text_IO.Put (To    => SR,

16                               Item  => C.Red,

17                               Base  => 16);

18      Ada.Integer_Text_IO.Put (To    => SG,

19                               Item  => C.Green,

20                               Base  => 16);

21      Ada.Integer_Text_IO.Put (To    => SB,

22                               Item  => C.Blue,

23                               Base  => 16);

24      return ("(Red => " & SR

25              & ", Green => " & SG

26              & ", Blue => "  & SB

27              &")");

28   end Image;

29

30end Color_Types;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Color_Types;          use Color_Types;

5

6procedure Main is

7   type Test_Case_Index is

8     (Color_Table_Chk,

9      HTML_Color_To_Integer_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12   begin

13      case TC is

14         when Color_Table_Chk =>

15            Put_Line ("Size of HTML_Color_RGB: "

16                      & Integer'Image (HTML_Color_RGB'Length));

17            Put_Line ("Firebrick: "

18                      & Image (To_RGB_Lookup_Table (Firebrick)));

19         when HTML_Color_To_Integer_Chk =>

20            for I in HTML_Color'Range loop

21               Put_Line (HTML_Color'Image (I) & " => "

22                         & Image (To_RGB (I)) & ".");

23            end loop;

24      end case;

25   end Check;

26

27begin

28   if Argument_Count < 1 then

29      Put_Line ("ERROR: missing arguments! Exiting...");

30      return;

31   elsif Argument_Count > 1 then

32      Put_Line ("Ignoring additional arguments...");

33   end if;

34

35   Check (Test_Case_Index'Value (Argument (1)));

36end Main;

Unconstrained Array

unconstrained_arrays.ads

1package Unconstrained_Arrays is

2

3   type My_Array is array (Positive range <>) of Integer;

4

5   procedure Init (A : in out My_Array);

6

7   function Init (I, L : Positive) return My_Array;

8

9   procedure Double (A : in out My_Array);

10

11   function Diff_Prev_Elem (A : My_Array) return My_Array;

12

13end Unconstrained_Arrays;

unconstrained_arrays.adb

1package body Unconstrained_Arrays is

2

3   procedure Init (A : in out My_Array) is

4      Y : Natural := A'Last;

5   begin

6      for I in A'Range loop

7         A (I) := Y;

8         Y := Y - 1;

9      end loop;

10   end Init;

11

12   function Init (I, L : Positive) return My_Array is

13      A : My_Array (I .. I + L - 1);

14   begin

15      Init (A);

16      return A;

17   end Init;

18

19   procedure Double (A : in out My_Array) is

20   begin

21      for I in A'Range loop

22         A (I) := A (I) * 2;

23      end loop;

24   end Double;

25

26   function Diff_Prev_Elem (A : My_Array) return My_Array is

27      A_Out : My_Array (A'Range);

28   begin

29      A_Out (A'First) := 0;

30      for I in A'First + 1 .. A'Last loop

31         A_Out (I) := A (I) - A (I - 1);

32      end loop;

33

34      return A_Out;

35   end Diff_Prev_Elem;

36

37end Unconstrained_Arrays;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Unconstrained_Arrays; use Unconstrained_Arrays;

5

6procedure Main is

7   type Test_Case_Index is

8     (Init_Chk,

9      Init_Proc_Chk,

10      Double_Chk,

11      Diff_Prev_Chk,

12      Diff_Prev_Single_Chk);

13

14   procedure Check (TC : Test_Case_Index) is

15      AA : My_Array (1 .. 5);

16      AB : My_Array (5 .. 9);

17

18      procedure Display (A : My_Array) is

19      begin

20         for I in A'Range loop

21            Put_Line (Integer'Image (A (I)));

22         end loop;

23      end Display;

24

25      procedure Local_Init (A : in out My_Array) is

26      begin

27         A := (1, 2, 5, 10, -10);

28      end Local_Init;

29

30   begin

31      case TC is

32      when Init_Chk =>

33         AA := Init (AA'First, AA'Length);

34         AB := Init (AB'First, AB'Length);

35         Display (AA);

36         Display (AB);

37      when Init_Proc_Chk =>

38         Init (AA);

39         Init (AB);

40         Display (AA);

41         Display (AB);

42      when Double_Chk =>

43         Local_Init (AB);

44         Double (AB);

45         Display (AB);

46      when Diff_Prev_Chk =>

47         Local_Init (AB);

48         AB := Diff_Prev_Elem (AB);

49         Display (AB);

50      when Diff_Prev_Single_Chk =>

51         declare

52            A1 : My_Array (1 .. 1) := (1 => 42);

53         begin

54            A1 := Diff_Prev_Elem (A1);

55            Display (A1);

56         end;

57      end case;

58   end Check;

59

60begin

61   if Argument_Count < 1 then

62      Put_Line ("ERROR: missing arguments! Exiting...");

63      return;

64   elsif Argument_Count > 1 then

65      Put_Line ("Ignoring additional arguments...");

66   end if;

67

68   Check (Test_Case_Index'Value (Argument (1)));

69end Main;

Product info

product_info_pkg.ads

1package Product_Info_Pkg is

2

3   subtype Quantity is Natural;

4

5   subtype Currency is Float;

6

7   type Product_Info is record

8      Units : Quantity;

9      Price : Currency;

10   end record;

11

12   type Product_Infos is array (Positive range <>) of Product_Info;

13

14   type Currency_Array is array (Positive range <>) of Currency;

15

16   procedure Total (P   : Product_Infos;

17                    Tot : out Currency_Array);

18

19   function Total (P : Product_Infos) return Currency_Array;

20

21   function Total (P : Product_Infos) return Currency;

22

23end Product_Info_Pkg;

product_info_pkg.adb

1package body Product_Info_Pkg is

2

3   --  Get total for single product

4   function Total (P : Product_Info) return Currency is

5      (Currency (P.Units) * P.Price);

6

7   procedure Total (P   : Product_Infos;

8                    Tot : out Currency_Array) is

9   begin

10      for I in P'Range loop

11         Tot (I) := Total (P (I));

12      end loop;

13   end Total;

14

15   function Total (P : Product_Infos) return Currency_Array

16   is

17      Tot : Currency_Array (P'Range);

18   begin

19      Total (P, Tot);

20      return Tot;

21   end Total;

22

23   function Total (P : Product_Infos) return Currency

24   is

25      Tot : Currency := 0.0;

26   begin

27     for I in P'Range loop

28         Tot := Tot + Total (P (I));

29      end loop;

30      return Tot;

31   end Total;

32

33end Product_Info_Pkg;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Product_Info_Pkg;   use Product_Info_Pkg;

5

6procedure Main is

7   package Currency_IO is new Ada.Text_IO.Float_IO (Currency);

8

9   type Test_Case_Index is

10     (Total_Func_Chk,

11      Total_Proc_Chk,

12      Total_Value_Chk);

13

14   procedure Check (TC : Test_Case_Index) is

15      subtype Test_Range is Positive range 1 .. 5;

16

17      P    : Product_Infos (Test_Range);

18      Tots : Currency_Array (Test_Range);

19      Tot  : Currency;

20

21      procedure Display (Tots : Currency_Array) is

22      begin

23         for I in Tots'Range loop

24            Currency_IO.Put (Tots (I));

25            New_Line;

26         end loop;

27      end Display;

28

29      procedure Local_Init (P : in out Product_Infos) is

30      begin

31         P := ((1,   0.5),

32               (2,  10.0),

33               (5,  40.0),

34               (10, 10.0),

35               (10, 20.0));

36      end Local_Init;

37

38   begin

39      Currency_IO.Default_Fore := 1;

40      Currency_IO.Default_Aft  := 2;

41      Currency_IO.Default_Exp  := 0;

42

43      case TC is

44      when Total_Func_Chk =>

45         Local_Init (P);

46         Tots := Total (P);

47         Display (Tots);

48      when Total_Proc_Chk =>

49         Local_Init (P);

50         Total (P, Tots);

51         Display (Tots);

52      when Total_Value_Chk =>

53         Local_Init (P);

54         Tot := Total (P);

55         Currency_IO.Put (Tot);

56         New_Line;

57      end case;

58   end Check;

59

60begin

61   if Argument_Count < 1 then

62      Put_Line ("ERROR: missing arguments! Exiting...");

63      return;

64   elsif Argument_Count > 1 then

65      Put_Line ("Ignoring additional arguments...");

66   end if;

67

68   Check (Test_Case_Index'Value (Argument (1)));

69end Main;

String_10

strings_10.ads

1package Strings_10 is

2

3   subtype String_10 is String (1 .. 10);

4

5   --  Using "type String_10 is..." is possible, too.

6

7   function To_String_10 (S : String) return String_10;

8

9end Strings_10;

strings_10.adb

1package body Strings_10 is

2

3   function To_String_10 (S : String) return String_10 is

4      S_Out : String_10;

5   begin

6      for I in String_10'First .. Integer'Min (String_10'Last, S'Last) loop

7         S_Out (I) := S (I);

8      end loop;

9

10      for I in Integer'Min (String_10'Last + 1, S'Last + 1) .. String_10'Last loop

11         S_Out (I) := ' ';

12      end loop;

13

14      return S_Out;

15   end To_String_10;

16

17end Strings_10;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Strings_10;         use Strings_10;

5

6procedure Main is

7   type Test_Case_Index is

8     (String_10_Long_Chk,

9      String_10_Short_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      SL   : constant String := "And this is a long string just for testing...";

13      SS   : constant String := "Hey!";

14      S_10 : String_10;

15

16   begin

17      case TC is

18      when String_10_Long_Chk =>

19         S_10 := To_String_10 (SL);

20         Put_Line (String (S_10));

21      when String_10_Short_Chk =>

22         S_10 := (others => ' ');

23         S_10 := To_String_10 (SS);

24         Put_Line (String (S_10));

25      end case;

26   end Check;

27

28begin

29   if Argument_Count < 1 then

30      Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting...");

31      return;

32   elsif Argument_Count > 1 then

33      Ada.Text_IO.Put_Line ("Ignoring additional arguments...");

34   end if;

35

36   Check (Test_Case_Index'Value (Argument (1)));

37end Main;

List of Names

names_ages.ads

1package Names_Ages is

2

3   Max_People : constant Positive := 10;

4

5   subtype Name_Type is String (1 .. 50);

6

7   type Age_Type is new Natural;

8

9   type Person is record

10      Name  : Name_Type;

11      Age   : Age_Type;

12   end record;

13

14   type People_Array is array (Positive range <>) of Person;

15

16   type People is record

17      People_A   : People_Array (1 .. Max_People);

18      Last_Valid : Natural;

19   end record;

20

21   procedure Reset (P : in out People);

22

23   procedure Add (P    : in out People;

24                  Name : String);

25

26   function Get (P    : People;

27                 Name : String) return Age_Type;

28

29   procedure Update (P    : in out People;

30                     Name : String;

31                     Age  : Age_Type);

32

33   procedure Display (P : People);

34

35end Names_Ages;

names_ages.adb

1with Ada.Text_IO;       use Ada.Text_IO;

2with Ada.Strings;       use Ada.Strings;

3with Ada.Strings.Fixed; use Ada.Strings.Fixed;

4

5package body Names_Ages is

6

7   function To_Name_Type (S : String) return Name_Type is

8      S_Out : Name_Type := (others => ' ');

9   begin

10      for I in 1 .. Integer'Min (S'Last, Name_Type'Last) loop

11         S_Out (I) := S (I);

12      end loop;

13

14      return S_Out;

15   end To_Name_Type;

16

17   procedure Init (P    : in out Person;

18                   Name :        String) is

19   begin

20      P.Name := To_Name_Type (Name);

21      P.Age := 0;

22   end Init;

23

24   function Match (P    : Person;

25                   Name : String) return Boolean is

26   begin

27      return P.Name = To_Name_Type (Name);

28   end Match;

29

30   function Get (P : Person) return Age_Type is

31   begin

32      return P.Age;

33   end Get;

34

35   procedure Update (P   : in out Person;

36                     Age :        Age_Type) is

37   begin

38      P.Age := Age;

39   end Update;

40

41   procedure Display (P : Person) is

42   begin

43      Put_Line ("NAME: " & Trim (P.Name, Right));

44      Put_Line ("AGE: "  & Age_Type'Image (P.Age));

45   end Display;

46

47   procedure Reset (P : in out People) is

48   begin

49      P.Last_Valid := 0;

50   end Reset;

51

52   procedure Add (P    : in out People;

53                  Name :        String) is

54   begin

55      P.Last_Valid := P.Last_Valid + 1;

56      Init (P.People_A (P.Last_Valid), Name);

57   end Add;

58

59   function Get (P    : People;

60                 Name : String) return Age_Type is

61   begin

62      for I in P.People_A'First .. P.Last_Valid loop

63         if Match (P.People_A (I), Name) then

64            return Get (P.People_A (I));

65         end if;

66      end loop;

67

68      return 0;

69   end Get;

70

71   procedure Update (P    : in out People;

72                     Name :        String;

73                     Age  :        Age_Type) is

74   begin

75      for I in P.People_A'First .. P.Last_Valid loop

76         if Match (P.People_A (I), Name) then

77            Update (P.People_A (I), Age);

78         end if;

79      end loop;

80   end Update;

81

82   procedure Display (P : People) is

83   begin

84      Put_Line ("LIST OF NAMES:");

85      for I in P.People_A'First .. P.Last_Valid loop

86         Display (P.People_A (I));

87      end loop;

88   end Display;

89

90end Names_Ages;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Names_Ages;         use Names_Ages;

5

6procedure Main is

7   type Test_Case_Index is

8     (Names_Ages_Chk,

9      Get_Age_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      P : People;

13   begin

14      case TC is

15      when Names_Ages_Chk =>

16         Reset (P);

17         Add (P, "John");

18         Add (P, "Patricia");

19         Add (P, "Josh");

20         Display (P);

21         Update (P, "John",     18);

22         Update (P, "Patricia", 35);

23         Update (P, "Josh",     53);

24         Display (P);

25      when Get_Age_Chk =>

26         Reset (P);

27         Add (P, "Peter");

28         Update (P, "Peter", 45);

29         Put_Line ("Peter is "

30                   & Age_Type'Image (Get (P, "Peter"))

31                   & " years old.");

32      end case;

33   end Check;

34

35begin

36   if Argument_Count < 1 then

37      Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting...");

38      return;

39   elsif Argument_Count > 1 then

40      Ada.Text_IO.Put_Line ("Ignoring additional arguments...");

41   end if;

42

43   Check (Test_Case_Index'Value (Argument (1)));

44end Main;

More About Types

Aggregate Initialization

aggregates.ads

1package Aggregates is

2

3   type Rec is record

4      W : Integer := 10;

5      X : Integer := 11;

6      Y : Integer := 12;

7      Z : Integer := 13;

8   end record;

9

10   type Int_Arr is array (1 .. 20) of Integer;

11

12   procedure Init (R : out Rec);

13

14   procedure Init_Some (A : out Int_Arr);

15

16   procedure Init (A : out Int_Arr);

17

18end Aggregates;

aggregates.adb

1package body Aggregates is

2

3   procedure Init (R : out Rec) is

4   begin

5      R := (X      => 100,

6            Y      => 200,

7            others => <>);

8   end Init;

9

10   procedure Init_Some (A : out Int_Arr) is

11   begin

12      A := (1 .. 5 => 99,

13            others => 100);

14   end Init_Some;

15

16   procedure Init (A : out Int_Arr) is

17   begin

18      A := (others => 5);

19   end Init;

20

21end Aggregates;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Aggregates;        use Aggregates;

5

6procedure Main is

7   --  Remark: the following line is not relevant.

8   F   : array (1 .. 10) of Float := (others => 42.42)

9     with Unreferenced;

10

11   type Test_Case_Index is

12     (Default_Rec_Chk,

13      Init_Rec_Chk,

14      Init_Some_Arr_Chk,

15      Init_Arr_Chk);

16

17   procedure Check (TC : Test_Case_Index) is

18      A : Int_Arr;

19      R : Rec;

20      DR : constant Rec := (others => <>);

21   begin

22      case TC is

23         when Default_Rec_Chk =>

24            R := DR;

25            Put_Line ("Record Default:");

26            Put_Line ("W => " & Integer'Image (R.W));

27            Put_Line ("X => " & Integer'Image (R.X));

28            Put_Line ("Y => " & Integer'Image (R.Y));

29            Put_Line ("Z => " & Integer'Image (R.Z));

30         when Init_Rec_Chk =>

31            Init (R);

32            Put_Line ("Record Init:");

33            Put_Line ("W => " & Integer'Image (R.W));

34            Put_Line ("X => " & Integer'Image (R.X));

35            Put_Line ("Y => " & Integer'Image (R.Y));

36            Put_Line ("Z => " & Integer'Image (R.Z));

37         when Init_Some_Arr_Chk =>

38            Init_Some (A);

39            Put_Line ("Array Init_Some:");

40            for I in A'Range loop

41               Put_Line (Integer'Image (I) & " "

42                         & Integer'Image (A (I)));

43            end loop;

44         when Init_Arr_Chk =>

45            Init (A);

46            Put_Line ("Array Init:");

47            for I in A'Range loop

48               Put_Line (Integer'Image (I) & " "

49                         & Integer'Image (A (I)));

50            end loop;

51      end case;

52   end Check;

53

54begin

55   if Argument_Count < 1 then

56      Put_Line ("ERROR: missing arguments! Exiting...");

57      return;

58   elsif Argument_Count > 1 then

59      Put_Line ("Ignoring additional arguments...");

60   end if;

61

62   Check (Test_Case_Index'Value (Argument (1)));

63end Main;

Versioning

versioning.ads

1package Versioning is

2

3   type Version is record

4      Major       : Natural;

5      Minor       : Natural;

6      Maintenance : Natural;

7   end record;

8

9   function Convert (V : Version) return String;

10

11   function Convert (V : Version) return Float;

12

13end Versioning;

versioning.adb

1with Ada.Strings; use Ada.Strings;

2with Ada.Strings.Fixed; use Ada.Strings.Fixed;

3

4package body Versioning is

5

6   function Image_Trim (N : Natural) return String is

7      S_N : constant String := Trim (Natural'Image (N), Left);

8   begin

9      return S_N;

10   end Image_Trim;

11

12   function Convert (V : Version) return String is

13      S_Major : constant String := Image_Trim (V.Major);

14      S_Minor : constant String := Image_Trim (V.Minor);

15      S_Maint : constant String := Image_Trim (V.Maintenance);

16   begin

17      return (S_Major & "." & S_Minor & "." & S_Maint);

18   end Convert;

19

20   function Convert (V : Version) return Float is

21   begin

22      return Float (V.Major) + (Float (V.Minor) / 10.0);

23   end Convert;

24

25end Versioning;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Versioning;        use Versioning;

5

6procedure Main is

7   type Test_Case_Index is

8     (Ver_String_Chk,

9      Ver_Float_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      V : constant Version := (1, 3, 23);

13   begin

14      case TC is

15         when Ver_String_Chk =>

16            Put_Line (Convert (V));

17         when Ver_Float_Chk =>

18            Put_Line (Float'Image (Convert (V)));

19      end case;

20   end Check;

21

22begin

23   if Argument_Count < 1 then

24      Put_Line ("ERROR: missing arguments! Exiting...");

25      return;

26   elsif Argument_Count > 1 then

27      Put_Line ("Ignoring additional arguments...");

28   end if;

29

30   Check (Test_Case_Index'Value (Argument (1)));

31end Main;

Simple todo list

todo_lists.ads

1package Todo_Lists is

2

3   type Todo_Item is access String;

4

5   type Todo_Items is array (Positive range <>) of Todo_Item;

6

7   type Todo_List (Max_Len : Natural) is record

8      Items : Todo_Items (1 .. Max_Len);

9      Last  : Natural := 0;

10   end record;

11

12   procedure Add (Todos : in out Todo_List;

13                  Item  : String);

14

15   procedure Display (Todos : Todo_List);

16

17end Todo_Lists;

todo_lists.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Todo_Lists is

4

5   procedure Add (Todos : in out Todo_List;

6                  Item  : String) is

7   begin

8      if Todos.Last < Todos.Items'Last then

9         Todos.Last := Todos.Last + 1;

10         Todos.Items (Todos.Last) := new String'(Item);

11      else

12         Put_Line ("ERROR: list is full!");

13      end if;

14   end Add;

15

16   procedure Display (Todos : Todo_List) is

17   begin

18      Put_Line ("TO-DO LIST");

19      for I in Todos.Items'First .. Todos.Last loop

20         Put_Line (Todos.Items (I).all);

21      end loop;

22   end Display;

23

24end Todo_Lists;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Todo_Lists;        use Todo_Lists;

5

6procedure Main is

7   type Test_Case_Index is

8     (Todo_List_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11      T : Todo_List (10);

12   begin

13      case TC is

14         when Todo_List_Chk =>

15            Add (T, "Buy milk");

16            Add (T, "Buy tea");

17            Add (T, "Buy present");

18            Add (T, "Buy tickets");

19            Add (T, "Pay electricity bill");

20            Add (T, "Schedule dentist appointment");

21            Add (T, "Call sister");

22            Add (T, "Revise spreasheet");

23            Add (T, "Edit entry page");

24            Add (T, "Select new design");

25            Add (T, "Create upgrade plan");

26            Display (T);

27      end case;

28   end Check;

29

30begin

31   if Argument_Count < 1 then

32      Put_Line ("ERROR: missing arguments! Exiting...");

33      return;

34   elsif Argument_Count > 1 then

35      Put_Line ("Ignoring additional arguments...");

36   end if;

37

38   Check (Test_Case_Index'Value (Argument (1)));

39end Main;

Price list

price_lists.ads

1package Price_Lists is

2

3   type Price_Type is delta 0.01 digits 12;

4

5   type Price_List_Array is array (Positive range <>) of Price_Type;

6

7   type Price_List (Max : Positive) is record

8      List : Price_List_Array (1 .. Max);

9      Last : Natural := 0;

10   end record;

11

12   type Price_Result (Ok : Boolean) is record

13      case Ok is

14         when False =>

15            null;

16         when True =>

17            Price : Price_Type;

18      end case;

19   end record;

20

21   procedure Reset (Prices : in out Price_List);

22

23   procedure Add (Prices : in out Price_List;

24                  Item   : Price_Type);

25

26   function Get (Prices : Price_List;

27                 Idx    : Positive) return Price_Result;

28

29   procedure Display (Prices : Price_List);

30

31end Price_Lists;

price_lists.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Price_Lists is

4

5   procedure Reset (Prices : in out Price_List) is

6   begin

7      Prices.Last := 0;

8   end Reset;

9

10   procedure Add (Prices : in out Price_List;

11                  Item   : Price_Type) is

12   begin

13      if Prices.Last < Prices.List'Last then

14         Prices.Last := Prices.Last + 1;

15         Prices.List (Prices.Last) := Item;

16      else

17         Put_Line ("ERROR: list is full!");

18      end if;

19   end Add;

20

21   function Get (Prices : Price_List;

22                 Idx    : Positive) return Price_Result is

23   begin

24      if (Idx >= Prices.List'First and then

25          Idx <= Prices.Last)          then

26         return Price_Result'(Ok    => True,

27                              Price => Prices.List (Idx));

28      else

29         return Price_Result'(Ok    => False);

30      end if;

31   end Get;

32

33   procedure Display (Prices : Price_List) is

34   begin

35      Put_Line ("PRICE LIST");

36      for I in Prices.List'First .. Prices.Last loop

37         Put_Line (Price_Type'Image (Prices.List (I)));

38      end loop;

39   end Display;

40

41end Price_Lists;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Price_Lists;       use Price_Lists;

5

6procedure Main is

7   type Test_Case_Index is

8     (Price_Type_Chk,

9      Price_List_Chk,

10      Price_List_Get_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13      L : Price_List (10);

14

15      procedure Local_Init_List is

16      begin

17         Reset (L);

18         Add (L, 1.45);

19         Add (L, 2.37);

20         Add (L, 3.21);

21         Add (L, 4.14);

22         Add (L, 5.22);

23         Add (L, 6.69);

24         Add (L, 7.77);

25         Add (L, 8.14);

26         Add (L, 9.99);

27         Add (L, 10.01);

28      end Local_Init_List;

29

30      procedure Get_Display (Idx : Positive) is

31         R : constant Price_Result := Get (L, Idx);

32      begin

33         Put_Line ("Attempt Get # " & Positive'Image (Idx));

34         if R.Ok then

35            Put_Line ("Element # " & Positive'Image (Idx)

36                      & " => "     & Price_Type'Image (R.Price));

37         else

38            declare

39            begin

40               Put_Line ("Element # " & Positive'Image (Idx)

41                         & " => "     & Price_Type'Image (R.Price));

42            exception

43               when others =>

44                  Put_Line ("Element not available (as expected)");

45            end;

46         end if;

47

48      end Get_Display;

49

50   begin

51      case TC is

52         when Price_Type_Chk =>

53            Put_Line ("The delta    value of Price_Type is "

54                      & Price_Type'Image (Price_Type'Delta) & ";");

55            Put_Line ("The minimum  value of Price_Type is "

56                      & Price_Type'Image (Price_Type'First) & ";");

57            Put_Line ("The maximum  value of Price_Type is "

58                      & Price_Type'Image (Price_Type'Last)  & ";");

59         when Price_List_Chk =>

60            Local_Init_List;

61            Display (L);

62         when Price_List_Get_Chk =>

63            Local_Init_List;

64            Get_Display (5);

65            Get_Display (40);

66      end case;

67   end Check;

68

69begin

70   if Argument_Count < 1 then

71      Put_Line ("ERROR: missing arguments! Exiting...");

72      return;

73   elsif Argument_Count > 1 then

74      Put_Line ("Ignoring additional arguments...");

75   end if;

76

77   Check (Test_Case_Index'Value (Argument (1)));

78end Main;

Privacy

Directions

directions.ads

1package Directions is

2

3   type Angle_Mod is mod 360;

4

5   type Direction is

6     (North,

7      Northwest,

8      West,

9      Southwest,

10      South,

11      Southeast,

12      East);

13

14   function To_Direction (N : Angle_Mod) return Direction;

15

16   type Ext_Angle is private;

17

18   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle;

19

20   procedure Display (N : Ext_Angle);

21

22private

23

24   type Ext_Angle is record

25      Angle_Elem     : Angle_Mod;

26      Direction_Elem : Direction;

27   end record;

28

29end Directions;

directions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Directions is

4

5   procedure Display (N : Ext_Angle) is

6   begin

7      Put_Line ("Angle: "

8                & Angle_Mod'Image (N.Angle_Elem)

9                & " => "

10                & Direction'Image (N.Direction_Elem)

11                & ".");

12   end Display;

13

14   function To_Direction (N : Angle_Mod) return Direction is

15   begin

16      case N is

17         when   0        => return East;

18         when   1 ..  89 => return Northwest;

19         when  90        => return North;

20         when  91 .. 179 => return Northwest;

21         when 180        => return West;

22         when 181 .. 269 => return Southwest;

23         when 270        => return South;

24         when 271 .. 359 => return Southeast;

25      end case;

26   end To_Direction;

27

28   function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is

29   begin

30      return (Angle_Elem     => N,

31              Direction_Elem => To_Direction (N));

32   end To_Ext_Angle;

33

34end Directions;

test_directions.adb

1with Directions; use Directions;

2

3procedure Test_Directions is

4   type Ext_Angle_Array is array (Positive range <>) of Ext_Angle;

5

6   All_Directions : constant Ext_Angle_Array (1 .. 6)

7     := (To_Ext_Angle (0),

8         To_Ext_Angle (45),

9         To_Ext_Angle (90),

10         To_Ext_Angle (91),

11         To_Ext_Angle (180),

12         To_Ext_Angle (270));

13

14begin

15   for I in All_Directions'Range loop

16      Display (All_Directions (I));

17   end loop;

18

19end Test_Directions;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Test_Directions;

5

6procedure Main is

7     type Test_Case_Index is

8     (Direction_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13      when Direction_Chk =>

14         Test_Directions;

15      end case;

16   end Check;

17

18begin

19   if Argument_Count < 1 then

20      Put_Line ("ERROR: missing arguments! Exiting...");

21      return;

22   elsif Argument_Count > 1 then

23      Put_Line ("Ignoring additional arguments...");

24   end if;

25

26   Check (Test_Case_Index'Value (Argument (1)));

27end Main;

Limited Strings

limited_strings.ads

1package Limited_Strings is

2

3   type Lim_String is limited private;

4

5   function Init (S : String) return Lim_String;

6

7   function Init (Max : Positive) return Lim_String;

8

9   procedure Put_Line (LS : Lim_String);

10

11   procedure Copy (From :        Lim_String;

12                   To   : in out Lim_String);

13

14   function "=" (Ref, Dut : Lim_String) return Boolean;

15

16private

17

18   type Lim_String is access String;

19

20end Limited_Strings;

limited_strings.adb

1with Ada.Text_IO;

2

3package body Limited_Strings

4is

5

6   function Init (S : String) return Lim_String is

7      LS : constant Lim_String := new String'(S);

8   begin

9      return Ls;

10   end Init;

11

12   function Init (Max : Positive) return Lim_String is

13      LS : constant Lim_String := new String (1 .. Max);

14   begin

15      LS.all := (others => '_');

16      return LS;

17   end Init;

18

19   procedure Put_Line (LS : Lim_String) is

20   begin

21      Ada.Text_IO.Put_Line (LS.all);

22   end Put_Line;

23

24   function Get_Min_Last (A, B : Lim_String) return Positive is

25   begin

26      return Positive'Min (A'Last, B'Last);

27   end Get_Min_Last;

28

29   procedure Copy (From :        Lim_String;

30                   To   : in out Lim_String) is

31      Min_Last : constant Positive := Get_Min_Last (From, To);

32   begin

33      To (To'First .. Min_Last)    := From (To'First .. Min_Last);

34      To (Min_Last + 1 .. To'Last) := (others => '_');

35   end;

36

37   function "=" (Ref, Dut : Lim_String) return Boolean is

38      Min_Last : constant Positive := Get_Min_Last (Ref, Dut);

39   begin

40      for I in Dut'First .. Min_Last loop

41         if Dut (I) /= Ref (I) then

42            return False;

43         end if;

44      end loop;

45

46      return True;

47   end;

48

49end Limited_Strings;

check_lim_string.adb

1with Ada.Text_IO;     use Ada.Text_IO;

2

3with Limited_Strings; use Limited_Strings;

4

5procedure Check_Lim_String is

6   S  : constant String := "----------";

7   S1 : constant Lim_String := Init ("Hello World");

8   S2 : constant Lim_String := Init (30);

9   S3 : Lim_String := Init (5);

10   S4 : Lim_String := Init (S & S & S);

11begin

12   Put ("S1 => ");

13   Put_Line (S1);

14   Put ("S2 => ");

15   Put_Line (S2);

16

17   if S1 = S2 then

18      Put_Line ("S1 is equal to S2.");

19   else

20      Put_Line ("S1 isn't equal to S2.");

21   end if;

22

23   Copy (From => S1, To => S3);

24   Put ("S3 => ");

25   Put_Line (S3);

26

27   if S1 = S3 then

28      Put_Line ("S1 is equal to S3.");

29   else

30      Put_Line ("S1 isn't equal to S3.");

31   end if;

32

33   Copy (From => S1, To => S4);

34   Put ("S4 => ");

35   Put_Line (S4);

36

37   if S1 = S4 then

38      Put_Line ("S1 is equal to S4.");

39   else

40      Put_Line ("S1 isn't equal to S4.");

41   end if;

42end Check_Lim_String;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Check_Lim_String;

5

6procedure Main is

7   type Test_Case_Index is

8     (Lim_String_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13      when Lim_String_Chk =>

14         Check_Lim_String;

15      end case;

16   end Check;

17

18begin

19   if Argument_Count < 1 then

20      Put_Line ("ERROR: missing arguments! Exiting...");

21      return;

22   elsif Argument_Count > 1 then

23      Put_Line ("Ignoring additional arguments...");

24   end if;

25

26   Check (Test_Case_Index'Value (Argument (1)));

27end Main;

Generics

Display Array

display_array.ads

1generic

2   type T_Range is range <>;

3   type T_Element is private;

4   type T_Array is array (T_Range range <>) of T_Element;

5   with function Image (E : T_Element) return String;

6procedure Display_Array (Header : String;

7                         A      : T_Array);

display_array.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Display_Array (Header : String;

4                         A      : T_Array) is

5begin

6   Put_Line (Header);

7   for I in A'Range loop

8      Put_Line (T_Range'Image (I) & ": " & Image (A (I)));

9   end loop;

10end Display_Array;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_Array;

5

6procedure Main is

7   type Test_Case_Index is (Int_Array_Chk,

8                            Point_Array_Chk);

9

10   procedure Test_Int_Array is

11      type Int_Array is array (Positive range <>) of Integer;

12

13      procedure Display_Int_Array is new

14        Display_Array (T_Range => Positive,

15                       T_Element => Integer,

16                       T_Array   => Int_Array,

17                       Image     => Integer'Image);

18

19      A : constant Int_Array (1 .. 5) := (1, 2, 5, 7, 10);

20   begin

21      Display_Int_Array ("Integers", A);

22   end Test_Int_Array;

23

24   procedure Test_Point_Array is

25      type Point is record

26         X : Float;

27         Y : Float;

28      end record;

29

30      type Point_Array is array (Natural range <>) of Point;

31

32      function Image (P : Point) return String is

33      begin

34         return "(" & Float'Image (P.X)

35           & ", " & Float'Image (P.Y) & ")";

36      end Image;

37

38      procedure Display_Point_Array is new

39        Display_Array (T_Range   => Natural,

40                       T_Element => Point,

41                       T_Array   => Point_Array,

42                       Image     => Image);

43

44      A : constant Point_Array (0 .. 3) := ((1.0, 0.5), (2.0, -0.5),

45                                            (5.0, 2.0), (-0.5, 2.0));

46   begin

47      Display_Point_Array ("Points", A);

48   end Test_Point_Array;

49

50   procedure Check (TC : Test_Case_Index) is

51   begin

52      case TC is

53         when Int_Array_Chk =>

54            Test_Int_Array;

55         when Point_Array_Chk =>

56            Test_Point_Array;

57      end case;

58   end Check;

59

60begin

61   if Argument_Count < 1 then

62      Put_Line ("ERROR: missing arguments! Exiting...");

63      return;

64   elsif Argument_Count > 1 then

65      Put_Line ("Ignoring additional arguments...");

66   end if;

67

68   Check (Test_Case_Index'Value (Argument (1)));

69end Main;

Average of Array of Float

average.ads

1generic

2   type T_Range is range <>;

3   type T_Element is digits <>;

4   type T_Array is array (T_Range range <>) of T_Element;

5function Average (A : T_Array) return T_Element;

average.adb

1function Average (A : T_Array) return T_Element is

2   Acc : Float := 0.0;

3begin

4   for I in A'Range loop

5      Acc := Acc + Float (A (I));

6   end loop;

7

8   return T_Element (Acc / Float (A'Length));

9end Average;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Average;

5

6procedure Main is

7   type Test_Case_Index is (Float_Array_Chk,

8                            Digits_7_Float_Array_Chk);

9

10   procedure Test_Float_Array is

11      type Float_Array is array (Positive range <>) of Float;

12

13      function Average_Float is new

14        Average (T_Range   => Positive,

15                 T_Element => Float,

16                 T_Array   => Float_Array);

17

18      A : constant Float_Array (1 .. 5) := (1.0, 3.0, 5.0, 7.5, -12.5);

19   begin

20      Put_Line ("Average: " & Float'Image (Average_Float (A)));

21   end Test_Float_Array;

22

23   procedure Test_Digits_7_Float_Array is

24      type Custom_Float is digits 7 range 0.0 .. 1.0;

25

26      type Float_Array is

27        array (Integer range <>) of Custom_Float;

28

29      function Average_Float is new

30        Average (T_Range   => Integer,

31                 T_Element => Custom_Float,

32                 T_Array   => Float_Array);

33

34      A : constant Float_Array (-1 .. 3) := (0.5, 0.0, 1.0, 0.6, 0.5);

35   begin

36      Put_Line ("Average: "

37                & Custom_Float'Image (Average_Float (A)));

38   end Test_Digits_7_Float_Array;

39

40   procedure Check (TC : Test_Case_Index) is

41   begin

42      case TC is

43         when Float_Array_Chk =>

44            Test_Float_Array;

45         when Digits_7_Float_Array_Chk =>

46            Test_Digits_7_Float_Array;

47      end case;

48   end Check;

49

50begin

51   if Argument_Count < 1 then

52      Put_Line ("ERROR: missing arguments! Exiting...");

53      return;

54   elsif Argument_Count > 1 then

55      Put_Line ("Ignoring additional arguments...");

56   end if;

57

58   Check (Test_Case_Index'Value (Argument (1)));

59end Main;

Average of Array of Any Type

average.ads

1generic

2   type T_Range is range <>;

3   type T_Element is private;

4   type T_Array is array (T_Range range <>) of T_Element;

5   with function To_Float (E : T_Element) return Float is <>;

6function Average (A : T_Array) return Float;

average.adb

1function Average (A : T_Array) return Float is

2   Acc : Float := 0.0;

3begin

4   for I in A'Range loop

5      Acc := Acc + To_Float (A (I));

6   end loop;

7

8   return Acc / Float (A'Length);

9end Average;

test_item.ads

1procedure Test_Item;

test_item.adb

1with Ada.Text_IO;      use Ada.Text_IO;

2

3with Average;

4

5procedure Test_Item is

6   package F_IO is new Ada.Text_IO.Float_IO (Float);

7

8   type Amount is delta 0.01 digits 12;

9

10   type Item is record

11      Quantity : Natural;

12      Price    : Amount;

13   end record;

14

15   type Item_Array is

16     array (Positive range <>) of Item;

17

18   function Get_Total (I : Item) return Float is

19     (Float (I.Quantity) * Float (I.Price));

20

21   function Get_Price (I : Item) return Float is

22     (Float (I.Price));

23

24   function Average_Total is new

25     Average (T_Range   => Positive,

26              T_Element => Item,

27              T_Array   => Item_Array,

28              To_Float  => Get_Total);

29

30   function Average_Price is new

31     Average (T_Range   => Positive,

32              T_Element => Item,

33              T_Array   => Item_Array,

34              To_Float  => Get_Price);

35

36   A : constant Item_Array (1 .. 4)

37     := ((Quantity =>  5,   Price => 10.00),

38         (Quantity => 80,   Price =>  2.50),

39         (Quantity => 40,   Price =>  5.00),

40         (Quantity => 20,   Price => 12.50));

41

42begin

43   Put ("Average per item & quantity: ");

44   F_IO.Put (Average_Total (A), 3, 2, 0);

45   New_Line;

46

47   Put ("Average price:               ");

48   F_IO.Put (Average_Price (A), 3, 2, 0);

49   New_Line;

50end Test_Item;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Test_Item;

5

6procedure Main is

7   type Test_Case_Index is (Item_Array_Chk);

8

9   procedure Check (TC : Test_Case_Index) is

10   begin

11      case TC is

12         when Item_Array_Chk =>

13            Test_Item;

14      end case;

15   end Check;

16

17begin

18   if Argument_Count < 1 then

19      Put_Line ("ERROR: missing arguments! Exiting...");

20      return;

21   elsif Argument_Count > 1 then

22      Put_Line ("Ignoring additional arguments...");

23   end if;

24

25   Check (Test_Case_Index'Value (Argument (1)));

26end Main;

Generic list

gen_list.ads

1generic

2   type Item is private;

3   type Items is array (Positive range <>) of Item;

4   Name       :        String;

5   List_Array : in out Items;

6   Last       : in out Natural;

7   with procedure Put (I : Item) is <>;

8package Gen_List is

9

10   procedure Init;

11

12   procedure Add (I      :     Item;

13                  Status : out Boolean);

14

15   procedure Display;

16

17end Gen_List;

gen_list.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Gen_List is

4

5   procedure Init is

6   begin

7      Last := List_Array'First - 1;

8   end Init;

9

10   procedure Add (I      :     Item;

11                  Status : out Boolean) is

12   begin

13      Status := Last < List_Array'Last;

14

15      if Status then

16         Last := Last + 1;

17         List_Array (Last) := I;

18      end if;

19   end Add;

20

21   procedure Display is

22   begin

23      Put_Line (Name);

24      for I in List_Array'First .. Last loop

25         Put (List_Array (I));

26         New_Line;

27      end loop;

28   end Display;

29

30end Gen_List;

test_int.ads

1procedure Test_Int;

test_int.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3with Gen_List;

4

5procedure Test_Int is

6

7   procedure Put (I : Integer) is

8   begin

9      Ada.Text_IO.Put (Integer'Image (I));

10   end Put;

11

12   type Integer_Array is array (Positive range <>) of Integer;

13

14   A : Integer_Array (1 .. 3);

15   L : Natural;

16

17   package Int_List is new

18     Gen_List (Item          => Integer,

19               Items         => Integer_Array,

20               Name          => "List of integers",

21               List_Array    => A,

22               Last          => L);

23

24   Success : Boolean;

25

26   procedure Display_Add_Success (Success : Boolean) is

27   begin

28      if Success then

29         Put_Line ("Added item successfully!");

30      else

31         Put_Line ("Couldn't add item!");

32      end if;

33

34   end Display_Add_Success;

35

36begin

37   Int_List.Init;

38

39   Int_List.Add (2, Success);

40   Display_Add_Success (Success);

41

42   Int_List.Add (5, Success);

43   Display_Add_Success (Success);

44

45   Int_List.Add (7, Success);

46   Display_Add_Success (Success);

47

48   Int_List.Add (8, Success);

49   Display_Add_Success (Success);

50

51   Int_List.Display;

52end Test_Int;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Test_Int;

5

6procedure Main is

7   type Test_Case_Index is (Int_Chk);

8

9   procedure Check (TC : Test_Case_Index) is

10   begin

11      case TC is

12         when Int_Chk =>

13            Test_Int;

14      end case;

15   end Check;

16

17begin

18   if Argument_Count < 1 then

19      Put_Line ("ERROR: missing arguments! Exiting...");

20      return;

21   elsif Argument_Count > 1 then

22      Put_Line ("Ignoring additional arguments...");

23   end if;

24

25   Check (Test_Case_Index'Value (Argument (1)));

26end Main;

Exceptions

Uninitialized Value

options.ads

1package Options is

2

3   type Option is (Uninitialized,

4                   Option_1,

5                   Option_2,

6                   Option_3);

7

8   Uninitialized_Value : exception;

9

10   function Image (O : Option) return String;

11

12end Options;

options.adb

1package body Options is

2

3   function Image (O : Option) return String is

4   begin

5      case O is

6         when Uninitialized =>

7            raise Uninitialized_Value with "Uninitialized value detected!";

8         when others =>

9            return Option'Image (O);

10      end case;

11   end Image;

12

13end Options;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Exceptions;   use Ada.Exceptions;

4

5with Options;          use Options;

6

7procedure Main is

8   type Test_Case_Index is

9     (Options_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12

13      procedure Check (O : Option) is

14      begin

15         Put_Line (Image (O));

16      exception

17         when E : Uninitialized_Value =>

18            Put_Line (Exception_Message (E));

19      end Check;

20

21   begin

22      case TC is

23      when Options_Chk =>

24         for O in Option loop

25            Check (O);

26         end loop;

27      end case;

28   end Check;

29

30begin

31   if Argument_Count < 1 then

32      Put_Line ("ERROR: missing arguments! Exiting...");

33      return;

34   elsif Argument_Count > 1 then

35      Put_Line ("Ignoring additional arguments...");

36   end if;

37

38   Check (Test_Case_Index'Value (Argument (1)));

39end Main;

Numerical Exception

tests.ads

1package Tests is

2

3   type Test_ID is (Test_1, Test_2);

4

5   Custom_Exception : exception;

6

7   procedure Num_Exception_Test (ID : Test_ID);

8

9end Tests;

tests.adb

1package body Tests is

2

3   pragma Warnings (Off, "variable ""C"" is assigned but never read");

4

5   procedure Num_Exception_Test (ID : Test_ID) is

6      A, B, C : Integer;

7   begin

8      case ID is

9         when Test_1 =>

10            A := Integer'Last;

11            B := Integer'Last;

12            C := A + B;

13         when Test_2 =>

14            raise Custom_Exception with "Custom_Exception raised!";

15      end case;

16   end Num_Exception_Test;

17

18   pragma Warnings (On, "variable ""C"" is assigned but never read");

19

20end Tests;

check_exception.adb

1with Tests;          use Tests;

2

3with Ada.Text_IO;    use Ada.Text_IO;

4with Ada.Exceptions; use Ada.Exceptions;

5

6procedure Check_Exception (ID : Test_ID) is

7begin

8   Num_Exception_Test (ID);

9exception

10   when Constraint_Error =>

11      Put_Line ("Constraint_Error detected!");

12   when E : others =>

13      Put_Line (Exception_Message (E));

14end Check_Exception;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Exceptions;   use Ada.Exceptions;

4

5with Tests;            use Tests;

6with Check_Exception;

7

8procedure Main is

9   type Test_Case_Index is

10     (Exception_1_Chk,

11      Exception_2_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      procedure Check_Handle_Exception (ID : Test_ID) is

16      begin

17         Check_Exception (ID);

18      exception

19         when Constraint_Error =>

20            Put_Line ("Constraint_Error"

21                      & " (raised by Check_Exception) detected!");

22         when E : others =>

23            Put_Line (Exception_Name (E)

24                      & " (raised by Check_Exception) detected!");

25      end Check_Handle_Exception;

26

27   begin

28      case TC is

29      when Exception_1_Chk =>

30         Check_Handle_Exception (Test_1);

31      when Exception_2_Chk =>

32         Check_Handle_Exception (Test_2);

33      end case;

34   end Check;

35

36begin

37   if Argument_Count < 1 then

38      Put_Line ("ERROR: missing arguments! Exiting...");

39      return;

40   elsif Argument_Count > 1 then

41      Put_Line ("Ignoring additional arguments...");

42   end if;

43

44   Check (Test_Case_Index'Value (Argument (1)));

45end Main;

Re-raising Exceptions

tests.ads

1package Tests is

2

3   type Test_ID is (Test_1, Test_2);

4

5   Custom_Exception, Another_Exception : exception;

6

7   procedure Num_Exception_Test (ID : Test_ID);

8

9end Tests;

tests.adb

1package body Tests is

2

3   pragma Warnings (Off, "variable ""C"" is assigned but never read");

4

5   procedure Num_Exception_Test (ID : Test_ID) is

6      A, B, C : Integer;

7   begin

8      case ID is

9         when Test_1 =>

10            A := Integer'Last;

11            B := Integer'Last;

12            C := A + B;

13         when Test_2 =>

14            raise Custom_Exception with "Custom_Exception raised!";

15      end case;

16   end Num_Exception_Test;

17

18   pragma Warnings (On, "variable ""C"" is assigned but never read");

19

20end Tests;

check_exception.ads

1with Tests; use Tests;

2

3procedure Check_Exception (ID : Test_ID);

check_exception.adb

1with Ada.Text_IO;    use Ada.Text_IO;

2with Ada.Exceptions; use Ada.Exceptions;

3

4procedure Check_Exception (ID : Test_ID) is

5begin

6   Num_Exception_Test (ID);

7exception

8   when Constraint_Error =>

9      Put_Line ("Constraint_Error detected!");

10      raise;

11   when E : others =>

12      Put_Line (Exception_Message (E));

13      raise Another_Exception;

14end Check_Exception;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Exceptions;   use Ada.Exceptions;

4

5with Tests;            use Tests;

6with Check_Exception;

7

8procedure Main is

9   type Test_Case_Index is

10     (Exception_1_Chk,

11      Exception_2_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      procedure Check_Handle_Exception (ID : Test_ID) is

16      begin

17         Check_Exception (ID);

18      exception

19         when Constraint_Error =>

20            Put_Line ("Constraint_Error"

21                      & " (raised by Check_Exception) detected!");

22         when E : others =>

23            Put_Line (Exception_Name (E)

24                      & " (raised by Check_Exception) detected!");

25      end Check_Handle_Exception;

26

27   begin

28      case TC is

29      when Exception_1_Chk =>

30         Check_Handle_Exception (Test_1);

31      when Exception_2_Chk =>

32         Check_Handle_Exception (Test_2);

33      end case;

34   end Check;

35

36begin

37   if Argument_Count < 1 then

38      Put_Line ("ERROR: missing arguments! Exiting...");

39      return;

40   elsif Argument_Count > 1 then

41      Put_Line ("Ignoring additional arguments...");

42   end if;

43

44   Check (Test_Case_Index'Value (Argument (1)));

45end Main;

Tasking

Display Service

display_services.ads

1package Display_Services is

2

3   task type Display_Service is

4      entry Display (S : String);

5      entry Display (I : Integer);

6   end Display_Service;

7

8end Display_Services;

display_services.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Display_Services is

4

5   task body Display_Service is

6   begin

7      loop

8         select

9            accept Display (S : String) do

10               Put_Line (S);

11            end Display;

12         or

13            accept Display (I : Integer) do

14               Put_Line (Integer'Image (I));

15            end Display;

16         or

17            terminate;

18         end select;

19      end loop;

20   end Display_Service;

21

22end Display_Services;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_Services; use Display_Services;

5

6procedure Main is

7   type Test_Case_Index is (Display_Service_Chk);

8

9   procedure Check (TC : Test_Case_Index) is

10      Display : Display_Service;

11   begin

12      case TC is

13         when Display_Service_Chk =>

14            Display.Display ("Hello");

15            delay 0.5;

16            Display.Display ("Hello again");

17            delay 0.5;

18            Display.Display (55);

19            delay 0.5;

20      end case;

21   end Check;

22

23begin

24   if Argument_Count < 1 then

25      Put_Line ("ERROR: missing arguments! Exiting...");

26      return;

27   elsif Argument_Count > 1 then

28      Put_Line ("Ignoring additional arguments...");

29   end if;

30

31   Check (Test_Case_Index'Value (Argument (1)));

32end Main;

Event Manager

event_managers.ads

1with Ada.Real_Time; use Ada.Real_Time;

2

3package Event_Managers is

4

5   task type Event_Manager is

6      entry Start (ID : Natural);

7      entry Event (T : Time);

8   end Event_Manager;

9

10end Event_Managers;

event_managers.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Event_Managers is

4

5   task body Event_Manager is

6      Event_ID    : Natural := 0;

7      Event_Delay : Time;

8   begin

9      accept Start (ID : Natural) do

10         Event_ID := ID;

11      end Start;

12

13      accept Event (T : Time) do

14         Event_Delay := T;

15      end Event;

16

17      delay until Event_Delay;

18

19      Put_Line ("Event #" & Natural'Image (Event_ID));

20   end Event_Manager;

21

22end Event_Managers;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Event_Managers;   use Event_Managers;

5with Ada.Real_Time;    use Ada.Real_Time;

6

7procedure Main is

8   type Test_Case_Index is (Event_Manager_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11      Ev_Mng : array (1 .. 5) of Event_Manager;

12   begin

13      case TC is

14         when Event_Manager_Chk =>

15            for I in Ev_Mng'Range loop

16               Ev_Mng (I).Start (I);

17            end loop;

18            Ev_Mng (1).Event (Clock + Seconds (5));

19            Ev_Mng (2).Event (Clock + Seconds (3));

20            Ev_Mng (3).Event (Clock + Seconds (1));

21            Ev_Mng (4).Event (Clock + Seconds (2));

22            Ev_Mng (5).Event (Clock + Seconds (4));

23      end case;

24   end Check;

25

26begin

27   if Argument_Count < 1 then

28      Put_Line ("ERROR: missing arguments! Exiting...");

29      return;

30   elsif Argument_Count > 1 then

31      Put_Line ("Ignoring additional arguments...");

32   end if;

33

34   Check (Test_Case_Index'Value (Argument (1)));

35end Main;

Generic Protected Queue

gen_queues.ads

1generic

2   type Queue_Index is mod <>;

3   type T is private;

4package Gen_Queues is

5

6   type Queue_Array is array (Queue_Index) of T;

7

8   protected type Queue is

9      function Empty return Boolean;

10      function Full return Boolean;

11      entry Push (V : T);

12      entry Pop (V : out T);

13   private

14      N   : Natural     := 0;

15      Idx : Queue_Index := Queue_Array'First;

16      A   : Queue_Array;

17   end Queue;

18

19end Gen_Queues;

gen_queues.adb

1package body Gen_Queues is

2

3   protected body Queue is

4

5      function Empty return Boolean is

6        (N = 0);

7

8      function Full return Boolean is

9         (N = A'Length);

10

11      entry Push (V : T) when not Full is

12      begin

13         A (Idx) := V;

14

15         Idx := Idx + 1;

16         N   := N + 1;

17      end Push;

18

19      entry Pop (V : out T) when not Empty is

20      begin

21         N := N - 1;

22

23         V := A (Idx - Queue_Index (N) - 1);

24      end Pop;

25

26   end Queue;

27

28end Gen_Queues;

queue_tests.ads

1package Queue_Tests is

2

3   procedure Simple_Test;

4

5   procedure Concurrent_Test;

6

7end Queue_Tests;

queue_tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3with Gen_Queues;

4

5package body Queue_Tests is

6

7   Max : constant := 10;

8   type Queue_Mod is mod Max;

9

10   procedure Simple_Test is

11      package Queues_Float is new Gen_Queues (Queue_Mod, Float);

12

13      Q_F : Queues_Float.Queue;

14      V   : Float;

15   begin

16      V := 10.0;

17      while not Q_F.Full loop

18         Q_F.Push (V);

19         V := V + 1.5;

20      end loop;

21

22      while not Q_F.Empty loop

23         Q_F.Pop (V);

24         Put_Line ("Value from queue: " & Float'Image (V));

25      end loop;

26   end Simple_Test;

27

28   procedure Concurrent_Test is

29      package Queues_Integer is new Gen_Queues (Queue_Mod, Integer);

30

31      Q_I : Queues_Integer.Queue;

32

33      task T_Producer;

34      task T_Consumer;

35

36      task body T_Producer is

37         V : Integer := 100;

38      begin

39         for I in 1 .. 2 * Max loop

40            Q_I.Push (V);

41            V := V + 1;

42         end loop;

43      end T_Producer;

44

45      task body T_Consumer is

46         V : Integer;

47      begin

48         delay 1.5;

49

50         while not Q_I.Empty loop

51            Q_I.Pop (V);

52            Put_Line ("Value from queue: " & Integer'Image (V));

53            delay 0.2;

54         end loop;

55      end T_Consumer;

56   begin

57      null;

58   end Concurrent_Test;

59

60end Queue_Tests;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Queue_Tests;      use Queue_Tests;

5

6procedure Main is

7   type Test_Case_Index is (Simple_Queue_Chk,

8                            Concurrent_Queue_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11   begin

12      case TC is

13         when Simple_Queue_Chk =>

14            Simple_Test;

15         when Concurrent_Queue_Chk =>

16            Concurrent_Test;

17      end case;

18   end Check;

19

20begin

21   if Argument_Count < 1 then

22      Put_Line ("ERROR: missing arguments! Exiting...");

23      return;

24   elsif Argument_Count > 1 then

25      Put_Line ("Ignoring additional arguments...");

26   end if;

27

28   Check (Test_Case_Index'Value (Argument (1)));

29end Main;

Design by contracts

Price Range

prices.ads

1package Prices is

2

3   type Amount is delta 10.0 ** (-2) digits 12;

4

5   --  subtype Price is Amount range 0.0 .. Amount'Last;

6

7   subtype Price is Amount

8     with Static_Predicate => Price >= 0.0;

9

10end Prices;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Prices;            use Prices;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Price_Range_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13

14      procedure Check_Range (A : Amount) is

15         P : constant Price := A;

16      begin

17         Put_Line ("Price: " & Price'Image (P));

18      end Check_Range;

19

20   begin

21      case TC is

22      when Price_Range_Chk =>

23         Check_Range (-2.0);

24      end case;

25   exception

26      when Constraint_Error =>

27         Put_Line ("Constraint_Error detected (NOT as expected).");

28      when Assert_Failure =>

29         Put_Line ("Assert_Failure detected (as expected).");

30   end Check;

31

32begin

33   if Argument_Count < 1 then

34      Put_Line ("ERROR: missing arguments! Exiting...");

35      return;

36   elsif Argument_Count > 1 then

37      Put_Line ("Ignoring additional arguments...");

38   end if;

39

40   Check (Test_Case_Index'Value (Argument (1)));

41end Main;

Pythagorean Theorem: Predicate

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is record

6      H      : Length := 0;

7      --  Hypotenuse

8      C1, C2 : Length := 0;

9      --  Catheti / legs

10   end record

11     with Dynamic_Predicate => H * H = C1 * C1 + C2 * C2;

12

13   function Init (H, C1, C2 : Length) return Right_Triangle is

14     ((H, C1, C2));

15

16end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Pythagorean Theorem: Precondition

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is record

6      H      : Length := 0;

7      --  Hypotenuse

8      C1, C2 : Length := 0;

9      --  Catheti / legs

10   end record;

11

12   function Init (H, C1, C2 : Length) return Right_Triangle is

13     ((H, C1, C2))

14       with Pre => H * H = C1 * C1 + C2 * C2;

15

16end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Pythagorean Theorem: Postcondition

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is record

6      H      : Length := 0;

7      --  Hypotenuse

8      C1, C2 : Length := 0;

9      --  Catheti / legs

10   end record;

11

12   function Init (H, C1, C2 : Length) return Right_Triangle is

13     ((H, C1, C2))

14       with Post => (Init'Result.H * Init'Result.H

15                     = Init'Result.C1 * Init'Result.C1

16                     + Init'Result.C2 * Init'Result.C2);

17

18end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Pythagorean Theorem: Type Invariant

triangles.ads

1package Triangles is

2

3   subtype Length is Integer;

4

5   type Right_Triangle is private

6     with Type_Invariant => Check (Right_Triangle);

7

8   function Check (T : Right_Triangle) return Boolean;

9

10   function Init (H, C1, C2 : Length) return Right_Triangle;

11

12private

13

14   type Right_Triangle is record

15      H      : Length := 0;

16      --  Hypotenuse

17      C1, C2 : Length := 0;

18      --  Catheti / legs

19   end record;

20

21   function Init (H, C1, C2 : Length) return Right_Triangle is

22     ((H, C1, C2));

23

24   function Check (T : Right_Triangle) return Boolean is

25     (T.H * T.H = T.C1 * T.C1 + T.C2 * T.C2);

26

27end Triangles;

triangles-io.ads

1package Triangles.IO is

2

3   function Image (T : Right_Triangle) return String;

4

5end Triangles.IO;

triangles-io.adb

1package body Triangles.IO is

2

3   function Image (T : Right_Triangle) return String is

4     ("("    & Length'Image (T.H)

5      & ", " & Length'Image (T.C1)

6      & ", " & Length'Image (T.C2)

7      & ")");

8

9end Triangles.IO;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3with System.Assertions; use System.Assertions;

4

5with Triangles;         use Triangles;

6with Triangles.IO;      use Triangles.IO;

7

8procedure Main is

9

10   type Test_Case_Index is

11     (Triangle_8_6_Pass_Chk,

12      Triangle_8_6_Fail_Chk,

13      Triangle_10_24_Pass_Chk,

14      Triangle_10_24_Fail_Chk,

15      Triangle_18_24_Pass_Chk,

16      Triangle_18_24_Fail_Chk);

17

18   procedure Check (TC : Test_Case_Index) is

19

20      procedure Check_Triangle (H, C1, C2 : Length) is

21         T : Right_Triangle;

22      begin

23         T := Init (H, C1, C2);

24         Put_Line (Image (T));

25      exception

26         when Constraint_Error =>

27            Put_Line ("Constraint_Error detected (NOT as expected).");

28         when Assert_Failure =>

29            Put_Line ("Assert_Failure detected (as expected).");

30      end Check_Triangle;

31

32   begin

33      case TC is

34         when Triangle_8_6_Pass_Chk   => Check_Triangle (10,  8,  6);

35         when Triangle_8_6_Fail_Chk   => Check_Triangle (12,  8,  6);

36         when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);

37         when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);

38         when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);

39         when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 1 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 1 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)));

52end Main;

Primary Colors

color_types.ads

1package Color_Types is

2

3   type HTML_Color is

4     (Salmon,

5      Firebrick,

6      Red,

7      Darkred,

8      Lime,

9      Forestgreen,

10      Green,

11      Darkgreen,

12      Blue,

13      Mediumblue,

14      Darkblue);

15

16   subtype Int_Color is Integer range 0 .. 255;

17

18   function Image (I : Int_Color) return String;

19

20   type RGB is record

21      Red   : Int_Color;

22      Green : Int_Color;

23      Blue  : Int_Color;

24   end record;

25

26   function To_RGB (C : HTML_Color) return RGB;

27

28   function Image (C : RGB) return String;

29

30   type HTML_Color_RGB_Array is array (HTML_Color) of RGB;

31

32   To_RGB_Lookup_Table : constant HTML_Color_RGB_Array

33     := (Salmon      => (16#FA#, 16#80#, 16#72#),

34         Firebrick   => (16#B2#, 16#22#, 16#22#),

35         Red         => (16#FF#, 16#00#, 16#00#),

36         Darkred     => (16#8B#, 16#00#, 16#00#),

37         Lime        => (16#00#, 16#FF#, 16#00#),

38         Forestgreen => (16#22#, 16#8B#, 16#22#),

39         Green       => (16#00#, 16#80#, 16#00#),

40         Darkgreen   => (16#00#, 16#64#, 16#00#),

41         Blue        => (16#00#, 16#00#, 16#FF#),

42         Mediumblue  => (16#00#, 16#00#, 16#CD#),

43         Darkblue    => (16#00#, 16#00#, 16#8B#));

44

45   subtype HTML_RGB_Color is HTML_Color

46     with Static_Predicate => HTML_RGB_Color in Red | Green | Blue;

47

48   function To_Int_Color (C : HTML_Color;

49                          S : HTML_RGB_Color) return Int_Color;

50   --  Convert to hexadecimal value for the selected RGB component S

51

52end Color_Types;

color_types.adb

1with Ada.Integer_Text_IO;

2

3package body Color_Types is

4

5   function To_RGB (C : HTML_Color) return RGB is

6   begin

7      return To_RGB_Lookup_Table (C);

8   end To_RGB;

9

10   function To_Int_Color (C : HTML_Color;

11                          S : HTML_RGB_Color) return Int_Color is

12      C_RGB : constant RGB := To_RGB (C);

13   begin

14      case S is

15         when Red   => return C_RGB.Red;

16         when Green => return C_RGB.Green;

17         when Blue  => return C_RGB.Blue;

18      end case;

19   end To_Int_Color;

20

21   function Image (I : Int_Color) return String is

22      subtype Str_Range is Integer range 1 .. 10;

23      S : String (Str_Range);

24   begin

25      Ada.Integer_Text_IO.Put (To    => S,

26                               Item  => I,

27                               Base  => 16);

28      return S;

29   end Image;

30

31   function Image (C : RGB) return String is

32   begin

33      return ("(Red => "      & Image (C.Red)

34              & ", Green => " & Image (C.Green)

35              & ", Blue => "  & Image (C.Blue)

36              &")");

37   end Image;

38

39end Color_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Color_Types;      use Color_Types;

5

6procedure Main is

7   type Test_Case_Index is

8     (HTML_Color_Red_Chk,

9      HTML_Color_Green_Chk,

10      HTML_Color_Blue_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13

14      procedure Check_HTML_Colors (S : HTML_RGB_Color) is

15      begin

16         Put_Line ("Selected: " & HTML_RGB_Color'Image (S));

17         for I in HTML_Color'Range loop

18            Put_Line (HTML_Color'Image (I) & " => "

19                      & Image (To_Int_Color (I, S)) & ".");

20         end loop;

21      end Check_HTML_Colors;

22

23   begin

24      case TC is

25         when HTML_Color_Red_Chk =>

26            Check_HTML_Colors (Red);

27         when HTML_Color_Green_Chk =>

28            Check_HTML_Colors (Green);

29         when HTML_Color_Blue_Chk =>

30            Check_HTML_Colors (Blue);

31      end case;

32   end Check;

33

34begin

35   if Argument_Count < 1 then

36      Put_Line ("ERROR: missing arguments! Exiting...");

37      return;

38   elsif Argument_Count > 1 then

39      Put_Line ("Ignoring additional arguments...");

40   end if;

41

42   Check (Test_Case_Index'Value (Argument (1)));

43end Main;

Object-oriented programming

Simple type extension

type_extensions.ads

1package Type_Extensions is

2

3   type T_Float is tagged record

4      F : Float;

5   end record;

6

7   function Init (F : Float) return T_Float;

8

9   function Init (I : Integer) return T_Float;

10

11   function Image (T : T_Float) return String;

12

13   type T_Mixed is new T_Float with record

14      I : Integer;

15   end record;

16

17   function Init (F : Float) return T_Mixed;

18

19   function Init (I : Integer) return T_Mixed;

20

21   function Image (T : T_Mixed) return String;

22

23end Type_Extensions;

type_extensions.adb

1package body Type_Extensions is

2

3   function Init (F : Float) return T_Float is

4   begin

5      return ((F => F));

6   end Init;

7

8   function Init (I : Integer) return T_Float is

9   begin

10      return ((F => Float (I)));

11   end Init;

12

13   function Init (F : Float) return T_Mixed is

14   begin

15      return ((F => F,

16               I => Integer (F)));

17   end Init;

18

19   function Init (I : Integer) return T_Mixed is

20   begin

21      return ((F => Float (I),

22               I => I));

23   end Init;

24

25   function Image (T : T_Float) return String is

26   begin

27      return "{ F => " & Float'Image (T.F) & " }";

28   end Image;

29

30   function Image (T : T_Mixed) return String is

31   begin

32      return "{ F => " & Float'Image (T.F)

33        & ", I => " & Integer'Image (T.I) & " }";

34   end Image;

35

36end Type_Extensions;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Type_Extensions;  use Type_Extensions;

5

6procedure Main is

7

8   type Test_Case_Index is

9     (Type_Extension_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      F1, F2 : T_Float;

13      M1, M2 : T_Mixed;

14   begin

15      case TC is

16      when Type_Extension_Chk =>

17         F1 := Init (2.0);

18         F2 := Init (3);

19         M1 := Init (4.0);

20         M2 := Init (5);

21

22         if M2 in T_Float'Class then

23           Put_Line ("T_Mixed is in T_Float'Class as expected");

24         end if;

25

26         Put_Line ("F1: " & Image (F1));

27         Put_Line ("F2: " & Image (F2));

28         Put_Line ("M1: " & Image (M1));

29         Put_Line ("M2: " & Image (M2));

30      end case;

31   end Check;

32

33begin

34   if Argument_Count < 1 then

35      Put_Line ("ERROR: missing arguments! Exiting...");

36      return;

37   elsif Argument_Count > 1 then

38      Put_Line ("Ignoring additional arguments...");

39   end if;

40

41   Check (Test_Case_Index'Value (Argument (1)));

42end Main;

Online Store

online_store.ads

1with Ada.Calendar; use Ada.Calendar;

2

3package Online_Store is

4

5   type Amount is delta 10.0**(-2) digits 10;

6

7   subtype Percentage is Amount range 0.0 .. 1.0;

8

9   type Member is tagged record

10      Start : Year_Number;

11   end record;

12

13   type Member_Access is access Member'Class;

14

15   function Get_Status (M : Member) return String;

16

17   function Get_Price (M : Member;

18                       P : Amount) return Amount;

19

20   type Full_Member is new Member with record

21      Discount : Percentage;

22   end record;

23

24   function Get_Status (M : Full_Member) return String;

25

26   function Get_Price (M : Full_Member;

27                       P : Amount) return Amount;

28

29end Online_Store;

online_store.adb

1package body Online_Store is

2

3   function Get_Status (M : Member) return String is

4     ("Associate Member");

5

6   function Get_Status (M : Full_Member) return String is

7     ("Full Member");

8

9   function Get_Price (M : Member;

10                       P : Amount) return Amount is (P);

11

12   function Get_Price (M : Full_Member;

13                       P : Amount) return Amount is

14     (P * (1.0 - M.Discount));

15

16end Online_Store;

online_store-tests.ads

1package Online_Store.Tests is

2

3   procedure Simple_Test;

4

5end Online_Store.Tests;

online_store-tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Online_Store.Tests is

4

5   procedure Simple_Test is

6

7      type Member_Due_Amount is record

8         Member     : Member_Access;

9         Due_Amount : Amount;

10      end record;

11

12      function Get_Price (MA : Member_Due_Amount) return Amount is

13      begin

14         return MA.Member.Get_Price (MA.Due_Amount);

15      end Get_Price;

16

17      type Member_Due_Amounts is array (Positive range <>) of Member_Due_Amount;

18

19      DB : constant Member_Due_Amounts (1 .. 4)

20        := ((Member     => new Member'(Start => 2010),

21             Due_Amount => 250.0),

22            (Member     => new Full_Member'(Start    => 1998,

23                                            Discount => 0.1),

24             Due_Amount => 160.0),

25            (Member     => new Full_Member'(Start    => 1987,

26                                            Discount => 0.2),

27             Due_Amount => 400.0),

28            (Member     => new Member'(Start => 2013),

29             Due_Amount => 110.0));

30   begin

31      for I in DB'Range loop

32         Put_Line ("Member #" & Positive'Image (I));

33         Put_Line ("Status: " & DB (I).Member.Get_Status);

34         Put_Line ("Since: " & Year_Number'Image (DB (I).Member.Start));

35         Put_Line ("Due Amount: " & Amount'Image (Get_Price (DB (I))));

36         Put_Line ("--------");

37      end loop;

38   end Simple_Test;

39

40end Online_Store.Tests;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Online_Store;       use Online_Store;

5with Online_Store.Tests; use Online_Store.Tests;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Type_Chk,

11      Unit_Test_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      function Result_Image (Result : Boolean) return String is

16        (if Result then "OK" else "not OK");

17

18   begin

19      case TC is

20      when Type_Chk =>

21         declare

22            AM : constant Member      := (Start    => 2002);

23            FM : constant Full_Member := (Start    => 1990,

24                                          Discount => 0.2);

25         begin

26            Put_Line ("Testing Status of Associate Member Type => "

27                      & Result_Image (AM.Get_Status = "Associate Member"));

28            Put_Line ("Testing Status of Full Member Type => "

29                      & Result_Image (FM.Get_Status = "Full Member"));

30            Put_Line ("Testing Discount of Associate Member Type => "

31                      & Result_Image (AM.Get_Price (100.0) = 100.0));

32            Put_Line ("Testing Discount of Full Member Type => "

33                      & Result_Image (FM.Get_Price (100.0) = 80.0));

34         end;

35         when Unit_Test_Chk =>

36            Simple_Test;

37      end case;

38   end Check;

39

40begin

41   if Argument_Count < 1 then

42      Put_Line ("ERROR: missing arguments! Exiting...");

43      return;

44   elsif Argument_Count > 1 then

45      Put_Line ("Ignoring additional arguments...");

46   end if;

47

48   Check (Test_Case_Index'Value (Argument (1)));

49end Main;

Standard library: Containers

Simple todo list

todo_lists.ads

1with Ada.Containers.Vectors;

2

3package Todo_Lists is

4

5   type Todo_Item is access String;

6

7   package Todo_List_Pkg is new Ada.Containers.Vectors

8     (Index_Type   => Natural,

9      Element_Type => Todo_Item);

10

11   subtype Todo_List is Todo_List_Pkg.Vector;

12

13   procedure Add (Todos : in out Todo_List;

14                  Item  : String);

15

16   procedure Display (Todos : Todo_List);

17

18end Todo_Lists;

todo_lists.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Todo_Lists is

4

5   procedure Add (Todos : in out Todo_List;

6                  Item  : String) is

7   begin

8      Todos.Append (new String'(Item));

9   end Add;

10

11   procedure Display (Todos : Todo_List) is

12   begin

13      Put_Line ("TO-DO LIST");

14      for T of Todos loop

15         Put_Line (T.all);

16      end loop;

17   end Display;

18

19end Todo_Lists;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Todo_Lists;        use Todo_Lists;

5

6procedure Main is

7   type Test_Case_Index is

8     (Todo_List_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11      T : Todo_List;

12   begin

13      case TC is

14         when Todo_List_Chk =>

15            Add (T, "Buy milk");

16            Add (T, "Buy tea");

17            Add (T, "Buy present");

18            Add (T, "Buy tickets");

19            Add (T, "Pay electricity bill");

20            Add (T, "Schedule dentist appointment");

21            Add (T, "Call sister");

22            Add (T, "Revise spreasheet");

23            Add (T, "Edit entry page");

24            Add (T, "Select new design");

25            Add (T, "Create upgrade plan");

26            Display (T);

27      end case;

28   end Check;

29

30begin

31   if Argument_Count < 1 then

32      Put_Line ("ERROR: missing arguments! Exiting...");

33      return;

34   elsif Argument_Count > 1 then

35      Put_Line ("Ignoring additional arguments...");

36   end if;

37

38   Check (Test_Case_Index'Value (Argument (1)));

39end Main;

List of unique integers

ops.ads

1with Ada.Containers.Ordered_Sets;

2

3package Ops is

4

5   type Int_Array is array (Positive range <>) of Integer;

6

7   package Integer_Sets is new Ada.Containers.Ordered_Sets

8     (Element_Type => Integer);

9

10   subtype Int_Set is Integer_Sets.Set;

11

12   function Get_Unique (A : Int_Array) return Int_Set;

13

14   function Get_Unique (A : Int_Array) return Int_Array;

15

16end Ops;

ops.adb

1package body Ops is

2

3   function Get_Unique (A : Int_Array) return Int_Set is

4      S : Int_Set;

5   begin

6      for E of A loop

7         S.Include (E);

8      end loop;

9

10      return S;

11   end Get_Unique;

12

13   function Get_Unique (A : Int_Array) return Int_Array is

14      S  : constant Int_Set := Get_Unique (A);

15      AR : Int_Array (1 .. Positive (S.Length));

16      I  : Positive := 1;

17   begin

18      for E of S loop

19         AR (I) := E;

20         I := I + 1;

21      end loop;

22

23      return AR;

24   end Get_Unique;

25

26end Ops;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4with Ops;                     use Ops;

5

6procedure Main is

7   type Test_Case_Index is

8     (Get_Unique_Set_Chk,

9      Get_Unique_Array_Chk);

10

11   procedure Check (TC : Test_Case_Index;

12                    A  : Int_Array) is

13

14      procedure Display_Unique_Set (A : Int_Array) is

15         S  : constant Int_Set := Get_Unique (A);

16      begin

17         for E of S loop

18            Put_Line (Integer'Image (E));

19         end loop;

20      end Display_Unique_Set;

21

22      procedure Display_Unique_Array (A : Int_Array) is

23         AU : constant Int_Array := Get_Unique (A);

24      begin

25         for E of AU loop

26            Put_Line (Integer'Image (E));

27         end loop;

28      end Display_Unique_Array;

29

30   begin

31      case TC is

32         when Get_Unique_Set_Chk   => Display_Unique_Set (A);

33         when Get_Unique_Array_Chk => Display_Unique_Array (A);

34      end case;

35   end Check;

36

37begin

38   if Argument_Count < 3 then

39      Put_Line ("ERROR: missing arguments! Exiting...");

40      return;

41   else

42      declare

43         A : Int_Array (1 .. Argument_Count - 1);

44      begin

45         for I in A'Range loop

46            A (I) := Integer'Value (Argument (1 + I));

47         end loop;

48         Check (Test_Case_Index'Value (Argument (1)), A);

49      end;

50   end if;

51end Main;

Standard library: Dates & Times

Holocene calendar

to_holocene_year.adb

1with Ada.Calendar; use Ada.Calendar;

2

3function To_Holocene_Year (T : Time) return Integer is

4begin

5   return Year (T) + 10_000;

6end To_Holocene_Year;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Calendar;            use Ada.Calendar;

4

5with To_Holocene_Year;

6

7procedure Main is

8   type Test_Case_Index is

9     (Holocene_Chk);

10

11   procedure Display_Holocene_Year (Y : Year_Number) is

12      HY : Integer;

13   begin

14      HY := To_Holocene_Year (Time_Of (Y, 1, 1));

15      Put_Line ("Year (Gregorian): " & Year_Number'Image (Y));

16      Put_Line ("Year (Holocene):  " & Integer'Image (HY));

17   end Display_Holocene_Year;

18

19   procedure Check (TC : Test_Case_Index) is

20   begin

21      case TC is

22         when Holocene_Chk =>

23            Display_Holocene_Year (2012);

24            Display_Holocene_Year (2020);

25      end case;

26   end Check;

27

28begin

29   if Argument_Count < 1 then

30      Put_Line ("ERROR: missing arguments! Exiting...");

31      return;

32   elsif Argument_Count > 1 then

33      Put_Line ("Ignoring additional arguments...");

34   end if;

35

36   Check (Test_Case_Index'Value (Argument (1)));

37end Main;

List of events

events.ads

1with Ada.Containers.Vectors;

2

3package Events is

4

5   type Event_Item is access String;

6

7   package Event_Item_Containers is new

8     Ada.Containers.Vectors

9       (Index_Type   => Positive,

10        Element_Type => Event_Item);

11

12   subtype Event_Items is Event_Item_Containers.Vector;

13

14end Events;

events-lists.ads

1with Ada.Calendar;                use Ada.Calendar;

2with Ada.Containers.Ordered_Maps;

3

4package Events.Lists is

5

6   type Event_List is tagged private;

7

8   procedure Add (Events     : in out Event_List;

9                  Event_Time :        Time;

10                  Event      :        String);

11

12   procedure Display (Events : Event_List);

13

14private

15

16   package Event_Time_Item_Containers is new

17     Ada.Containers.Ordered_Maps

18       (Key_Type         => Time,

19        Element_Type     => Event_Items,

20        "="              => Event_Item_Containers."=");

21

22   type Event_List is new Event_Time_Item_Containers.Map with null record;

23

24end Events.Lists;

events-lists.adb

1with Ada.Text_IO;             use Ada.Text_IO;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3

4package body Events.Lists is

5

6   procedure Add (Events     : in out Event_List;

7                  Event_Time : Time;

8                  Event      : String) is

9      use Event_Item_Containers;

10      E : constant Event_Item := new String'(Event);

11   begin

12      if not Events.Contains (Event_Time) then

13         Events.Include (Event_Time, Empty_Vector);

14      end if;

15      Events (Event_Time).Append (E);

16   end Add;

17

18   function Date_Image (T : Time) return String is

19      Date_Img : constant String := Image (T);

20   begin

21      return Date_Img (1 .. 10);

22   end;

23

24   procedure Display (Events : Event_List) is

25      use Event_Time_Item_Containers;

26      T : Time;

27   begin

28      Put_Line ("EVENTS LIST");

29      for C in Events.Iterate loop

30         T := Key (C);

31         Put_Line ("- " & Date_Image (T));

32         for I of Events (C) loop

33            Put_Line ("    - " & I.all);

34         end loop;

35      end loop;

36   end Display;

37

38end Events.Lists;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Calendar;

4with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

5

6with Events.Lists;            use Events.Lists;

7

8procedure Main is

9   type Test_Case_Index is

10     (Event_List_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13      EL : Event_List;

14   begin

15      case TC is

16         when Event_List_Chk =>

17            EL.Add (Time_Of (2018, 2, 16),

18                    "Final check");

19            EL.Add (Time_Of (2018, 2, 16),

20                    "Release");

21            EL.Add (Time_Of (2018, 12, 3),

22                    "Brother's birthday");

23            EL.Add (Time_Of (2018, 1, 1),

24                    "New Year's Day");

25            EL.Display;

26      end case;

27   end Check;

28

29begin

30   if Argument_Count < 1 then

31      Put_Line ("ERROR: missing arguments! Exiting...");

32      return;

33   elsif Argument_Count > 1 then

34      Put_Line ("Ignoring additional arguments...");

35   end if;

36

37   Check (Test_Case_Index'Value (Argument (1)));

38end Main;

Standard library: Strings

Concatenation

str_concat.ads

1with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

2

3package Str_Concat is

4

5   type Unbounded_Strings is array (Positive range <>) of Unbounded_String;

6

7   function Concat (USA            : Unbounded_Strings;

8                    Trim_Str       : Boolean;

9                    Add_Whitespace : Boolean) return Unbounded_String;

10

11   function Concat (USA            : Unbounded_Strings;

12                    Trim_Str       : Boolean;

13                    Add_Whitespace : Boolean) return String;

14

15end Str_Concat;

str_concat.adb

1with Ada.Strings; use Ada.Strings;

2

3package body Str_Concat is

4

5   function Concat (USA            : Unbounded_Strings;

6                    Trim_Str       : Boolean;

7                    Add_Whitespace : Boolean) return Unbounded_String is

8

9      function Retrieve (USA        : Unbounded_Strings;

10                         Trim_Str   : Boolean;

11                         Index      : Positive) return Unbounded_String is

12         US_Internal : Unbounded_String := USA (Index);

13      begin

14         if Trim_Str then

15            US_Internal := Trim (US_Internal, Both);

16         end if;

17         return US_Internal;

18      end Retrieve;

19

20      US : Unbounded_String := To_Unbounded_String ("");

21   begin

22      for I in USA'First .. USA'Last - 1 loop

23         US := US & Retrieve (USA, Trim_Str, I);

24         if Add_Whitespace then

25            US := US & " ";

26         end if;

27      end loop;

28      US := US & Retrieve (USA, Trim_Str, USA'Last);

29

30      return US;

31   end Concat;

32

33   function Concat (USA            : Unbounded_Strings;

34                    Trim_Str       : Boolean;

35                    Add_Whitespace : Boolean) return String is

36   begin

37      return To_String (Concat (USA, Trim_Str, Add_Whitespace));

38   end Concat;

39

40end Str_Concat;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;

4

5with Str_Concat;              use Str_Concat;

6

7procedure Main is

8   type Test_Case_Index is

9     (Unbounded_Concat_No_Trim_No_WS_Chk,

10      Unbounded_Concat_Trim_No_WS_Chk,

11      String_Concat_Trim_WS_Chk,

12      Concat_Single_Element);

13

14   procedure Check (TC : Test_Case_Index) is

15   begin

16      case TC is

17         when Unbounded_Concat_No_Trim_No_WS_Chk =>

18            declare

19               S : constant Unbounded_Strings := (

20                  To_Unbounded_String ("Hello"),

21                  To_Unbounded_String (" World"),

22                  To_Unbounded_String ("!"));

23            begin

24               Put_Line (To_String (Concat (S, False, False)));

25            end;

26         when Unbounded_Concat_Trim_No_WS_Chk =>

27            declare

28               S : constant Unbounded_Strings := (

29                  To_Unbounded_String (" This "),

30                  To_Unbounded_String (" _is_ "),

31                  To_Unbounded_String ("  a   "),

32                  To_Unbounded_String (" _check "));

33            begin

34               Put_Line (To_String (Concat (S, True, False)));

35            end;

36         when String_Concat_Trim_WS_Chk =>

37            declare

38               S : constant Unbounded_Strings := (

39                   To_Unbounded_String ("  This  "),

40                   To_Unbounded_String ("  is a  "),

41                   To_Unbounded_String ("  test.  "));

42            begin

43               Put_Line (Concat (S, True, True));

44            end;

45         when Concat_Single_Element =>

46            declare

47               S : constant Unbounded_Strings := (

48                   1 => To_Unbounded_String ("  Hi "));

49            begin

50               Put_Line (Concat (S, True, True));

51            end;

52      end case;

53   end Check;

54

55begin

56   if Argument_Count < 1 then

57      Put_Line ("ERROR: missing arguments! Exiting...");

58      return;

59   elsif Argument_Count > 1 then

60      Put_Line ("Ignoring additional arguments...");

61   end if;

62

63   Check (Test_Case_Index'Value (Argument (1)));

64end Main;

List of events

events.ads

1with Ada.Strings.Unbounded;  use Ada.Strings.Unbounded;

2with Ada.Containers.Vectors;

3

4package Events is

5

6   subtype Event_Item is Unbounded_String;

7

8   package Event_Item_Containers is new

9     Ada.Containers.Vectors

10       (Index_Type   => Positive,

11        Element_Type => Event_Item);

12

13   subtype Event_Items is Event_Item_Containers.Vector;

14

15end Events;

events-lists.ads

1with Ada.Calendar;                use Ada.Calendar;

2with Ada.Containers.Ordered_Maps;

3

4package Events.Lists is

5

6   type Event_List is tagged private;

7

8   procedure Add (Events     : in out Event_List;

9                  Event_Time :        Time;

10                  Event      :        String);

11

12   procedure Display (Events : Event_List);

13

14private

15

16   package Event_Time_Item_Containers is new

17     Ada.Containers.Ordered_Maps

18       (Key_Type         => Time,

19        Element_Type     => Event_Items,

20        "="              => Event_Item_Containers."=");

21

22   type Event_List is new Event_Time_Item_Containers.Map with null record;

23

24end Events.Lists;

events-lists.adb

1with Ada.Text_IO;             use Ada.Text_IO;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3

4package body Events.Lists is

5

6   procedure Add (Events     : in out Event_List;

7                  Event_Time : Time;

8                  Event      : String) is

9      use Event_Item_Containers;

10      E : constant Event_Item := To_Unbounded_String (Event);

11   begin

12      if not Events.Contains (Event_Time) then

13         Events.Include (Event_Time, Empty_Vector);

14      end if;

15      Events (Event_Time).Append (E);

16   end Add;

17

18   function Date_Image (T : Time) return String is

19      Date_Img : constant String := Image (T);

20   begin

21      return Date_Img (1 .. 10);

22   end;

23

24   procedure Display (Events : Event_List) is

25      use Event_Time_Item_Containers;

26      T : Time;

27   begin

28      Put_Line ("EVENTS LIST");

29      for C in Events.Iterate loop

30         T := Key (C);

31         Put_Line ("- " & Date_Image (T));

32         for I of Events (C) loop

33            Put_Line ("    - " & To_String (I));

34         end loop;

35      end loop;

36   end Display;

37

38end Events.Lists;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Calendar;

4with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

5with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;

6

7with Events;

8with Events.Lists;            use Events.Lists;

9

10procedure Main is

11   type Test_Case_Index is

12     (Unbounded_String_Chk,

13      Event_List_Chk);

14

15   procedure Check (TC : Test_Case_Index) is

16      EL : Event_List;

17   begin

18      case TC is

19         when Unbounded_String_Chk =>

20            declare

21               S : constant Events.Event_Item := To_Unbounded_String ("Checked");

22            begin

23               Put_Line (To_String (S));

24            end;

25         when Event_List_Chk =>

26            EL.Add (Time_Of (2018, 2, 16),

27                    "Final check");

28            EL.Add (Time_Of (2018, 2, 16),

29                    "Release");

30            EL.Add (Time_Of (2018, 12, 3),

31                    "Brother's birthday");

32            EL.Add (Time_Of (2018, 1, 1),

33                    "New Year's Day");

34            EL.Display;

35      end case;

36   end Check;

37

38begin

39   if Argument_Count < 1 then

40      Put_Line ("ERROR: missing arguments! Exiting...");

41      return;

42   elsif Argument_Count > 1 then

43      Put_Line ("Ignoring additional arguments...");

44   end if;

45

46   Check (Test_Case_Index'Value (Argument (1)));

47end Main;

Standard library: Numerics

Decibel Factor

decibels.ads

1package Decibels is

2

3   subtype Decibel is Float;

4   subtype Factor  is Float;

5

6   function To_Decibel (F : Factor) return Decibel;

7

8   function To_Factor (D : Decibel) return Factor;

9

10end Decibels;

decibels.adb

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

2

3package body Decibels is

4

5   function To_Decibel (F : Factor) return Decibel is

6   begin

7      return 20.0 * Log (F, 10.0);

8   end To_Decibel;

9

10   function To_Factor (D : Decibel) return Factor is

11   begin

12      return 10.0 ** (D / 20.0);

13   end To_Factor;

14

15end Decibels;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Decibels;         use Decibels;

5

6procedure Main is

7   type Test_Case_Index is

8     (Db_Chk,

9      Factor_Chk);

10

11   procedure Check (TC : Test_Case_Index; V : Float) is

12

13      package F_IO is new Ada.Text_IO.Float_IO (Factor);

14      package D_IO is new Ada.Text_IO.Float_IO (Decibel);

15

16      procedure Put_Decibel_Cnvt (D : Decibel) is

17         F : constant Factor := To_Factor (D);

18      begin

19         D_IO.Put (D, 0, 2, 0);

20         Put (" dB => Factor of ");

21         F_IO.Put (F, 0, 2, 0);

22         New_Line;

23      end;

24

25      procedure Put_Factor_Cnvt (F : Factor) is

26         D : constant Decibel := To_Decibel (F);

27      begin

28         Put ("Factor of ");

29         F_IO.Put (F, 0, 2, 0);

30         Put (" => ");

31         D_IO.Put (D, 0, 2, 0);

32         Put_Line (" dB");

33      end;

34   begin

35      case TC is

36         when Db_Chk =>

37            Put_Decibel_Cnvt (Decibel (V));

38         when Factor_Chk =>

39            Put_Factor_Cnvt (Factor (V));

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 2 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 2 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)), Float'Value (Argument (2)));

52end Main;

Root-Mean-Square

signals.ads

1package Signals is

2

3   subtype Sig_Value is Float;

4

5   type Signal is array (Natural range <>) of Sig_Value;

6

7   function Rms (S : Signal) return Sig_Value;

8

9end Signals;

signals.adb

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

2

3package body Signals is

4

5   function Rms (S : Signal) return Sig_Value is

6      Acc : Float := 0.0;

7   begin

8      for V of S loop

9         Acc := Acc + V * V;

10      end loop;

11

12      return Sqrt (Acc / Float (S'Length));

13   end;

14

15end Signals;

signals-std.ads

1package Signals.Std is

2

3   Sample_Rate : Float := 8000.0;

4

5   function Generate_Sine (N : Positive; Freq : Float) return Signal;

6

7   function Generate_Square (N : Positive) return Signal;

8

9   function Generate_Triangular (N : Positive) return Signal;

10

11end Signals.Std;

signals-std.adb

1with Ada.Numerics;                      use Ada.Numerics;

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

3

4package body Signals.Std is

5

6   function Generate_Sine (N : Positive; Freq : Float) return Signal is

7      S : Signal (0 .. N - 1);

8   begin

9      for I in S'First .. S'Last loop

10         S (I) := 1.0 * Sin (2.0 * Pi * (Freq * Float (I) / Sample_Rate));

11      end loop;

12

13      return S;

14   end;

15

16   function Generate_Square (N : Positive) return Signal is

17      S : constant Signal (0 .. N - 1) := (others => 1.0);

18   begin

19      return S;

20   end;

21

22   function Generate_Triangular (N : Positive) return Signal is

23      S      : Signal (0 .. N - 1);

24      S_Half : constant Natural := S'Last / 2;

25   begin

26      for I in S'First .. S_Half loop

27         S (I) := 1.0 * (Float (I) / Float (S_Half));

28      end loop;

29      for I in S_Half .. S'Last loop

30         S (I) := 1.0 - (1.0 * (Float (I - S_Half) / Float (S_Half)));

31      end loop;

32

33      return S;

34   end;

35

36end Signals.Std;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4with Signals;                 use Signals;

5with Signals.Std;             use Signals.Std;

6

7procedure Main is

8   type Test_Case_Index is

9     (Sine_Signal_Chk,

10      Square_Signal_Chk,

11      Triangular_Signal_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14      package Sig_IO is new Ada.Text_IO.Float_IO (Sig_Value);

15

16      N    : constant Positive := 1024;

17      S_Si : constant Signal := Generate_Sine (N, 440.0);

18      S_Sq : constant Signal := Generate_Square (N);

19      S_Tr : constant Signal := Generate_Triangular (N + 1);

20   begin

21      case TC is

22         when Sine_Signal_Chk =>

23            Put ("RMS of Sine Signal: ");

24            Sig_IO.Put (Rms (S_Si), 0, 2, 0);

25            New_Line;

26         when Square_Signal_Chk =>

27            Put ("RMS of Square Signal: ");

28            Sig_IO.Put (Rms (S_Sq), 0, 2, 0);

29            New_Line;

30         when Triangular_Signal_Chk =>

31            Put ("RMS of Triangular Signal: ");

32            Sig_IO.Put (Rms (S_Tr), 0, 2, 0);

33            New_Line;

34      end case;

35   end Check;

36

37begin

38   if Argument_Count < 1 then

39      Put_Line ("ERROR: missing arguments! Exiting...");

40      return;

41   elsif Argument_Count > 1 then

42      Put_Line ("Ignoring additional arguments...");

43   end if;

44

45   Check (Test_Case_Index'Value (Argument (1)));

46end Main;

Rotation

rotation.ads

1with Ada.Numerics.Complex_Types;

2use  Ada.Numerics.Complex_Types;

3

4package Rotation is

5

6   type Complex_Points is array (Positive range <>) of Complex;

7

8   function Rotation (N : Positive) return Complex_Points;

9

10end Rotation;

rotation.adb

1with Ada.Numerics; use Ada.Numerics;

2

3package body Rotation is

4

5   function Rotation (N : Positive) return Complex_Points is

6      C_Angle : constant Complex :=

7                  Compose_From_Polar (1.0, 2.0 * Pi / Float (N));

8   begin

9      return C : Complex_Points (1 .. N + 1) do

10         C (1) := Compose_From_Cartesian (1.0, 0.0);

11

12         for I in C'First + 1 .. C'Last loop

13            C (I) := C (I - 1) * C_Angle;

14         end loop;

15      end return;

16   end;

17

18end Rotation;

angles.ads

1with Rotation; use Rotation;

2

3package Angles is

4

5   subtype Angle is Float;

6

7   type Angles is array (Positive range <>) of Angle;

8

9   function To_Angles (C : Complex_Points) return Angles;

10

11end Angles;

angles.adb

1with Ada.Numerics;               use Ada.Numerics;

2with Ada.Numerics.Complex_Types; use Ada.Numerics.Complex_Types;

3

4package body Angles is

5

6   function To_Angles (C : Complex_Points) return Angles is

7   begin

8      return A : Angles (C'Range) do

9         for I in A'Range loop

10            A (I) := Argument (C (I)) / Pi * 180.0;

11         end loop;

12      end return;

13   end To_Angles;

14

15end Angles;

rotation-tests.ads

1package Rotation.Tests is

2

3   procedure Test_Rotation (N : Positive);

4

5   procedure Test_Angles (N : Positive);

6

7end Rotation.Tests;

rotation-tests.adb

1with Ada.Text_IO;            use Ada.Text_IO;

2with Ada.Text_IO.Complex_IO;

3with Ada.Numerics;           use Ada.Numerics;

4

5with Angles;                 use Angles;

6

7package body Rotation.Tests is

8

9   package C_IO is new Ada.Text_IO.Complex_IO (Complex_Types);

10   package F_IO is new Ada.Text_IO.Float_IO (Float);

11

12   --

13   --  Adapt value due to floating-point inaccuracies

14   --

15

16   function Adapt (C : Complex) return Complex is

17      function Check_Zero (F : Float) return Float is

18        (if F <= 0.0 and F >= -0.01 then 0.0 else F);

19   begin

20      return C_Out : Complex := C do

21         C_Out.Re := Check_Zero (C_Out.Re);

22         C_Out.Im := Check_Zero (C_Out.Im);

23      end return;

24   end Adapt;

25

26   function Adapt (A : Angle) return Angle is

27     (if A <= -179.99 and A >= -180.01 then 180.0 else A);

28

29   procedure Test_Rotation (N : Positive) is

30      C : constant Complex_Points := Rotation (N);

31   begin

32      Put_Line ("---- Points for " & Positive'Image (N) & " slices ----");

33      for V of C loop

34         Put ("Point: ");

35         C_IO.Put (Adapt (V), 0, 1, 0);

36         New_Line;

37      end loop;

38   end Test_Rotation;

39

40   procedure Test_Angles (N : Positive) is

41      C : constant Complex_Points := Rotation (N);

42      A : constant Angles.Angles  := To_Angles (C);

43   begin

44      Put_Line ("---- Angles for " & Positive'Image (N) & " slices ----");

45      for V of A loop

46         Put ("Angle: ");

47         F_IO.Put (Adapt (V), 0, 2, 0);

48         Put_Line (" degrees");

49      end loop;

50   end Test_Angles;

51

52end Rotation.Tests;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4with Rotation.Tests;          use Rotation.Tests;

5

6procedure Main is

7   type Test_Case_Index is

8     (Rotation_Chk,

9      Angles_Chk);

10

11   procedure Check (TC : Test_Case_Index; N : Positive) is

12   begin

13      case TC is

14         when Rotation_Chk =>

15            Test_Rotation (N);

16         when Angles_Chk =>

17            Test_Angles (N);

18      end case;

19   end Check;

20

21begin

22   if Argument_Count < 2 then

23      Put_Line ("ERROR: missing arguments! Exiting...");

24      return;

25   elsif Argument_Count > 2 then

26      Put_Line ("Ignoring additional arguments...");

27   end if;

28

29   Check (Test_Case_Index'Value (Argument (1)), Positive'Value (Argument (2)));

30end Main;

Footnotes

Standard library: Containers

Simple todo list

Goal: implement a simple to-do list system using vectors.

Steps:

1. Implement the Todo_Lists package.

1. Declare the Todo_Item type.

2. Declare the Todo_List type.

3. Implement the Add procedure.

4. Implement the Display procedure.

2. Todo_Item type is used to store to-do items.

1. It should be implemented as an access type to strings.

3. Todo_List type is the container for all to-do items.

1. It should be implemented as a vector.

4. Procedure Add adds items (of Todo_Item type) to the list (of Todo_List type).

1. This requires allocating a string for the access type.

5. Procedure Display is used to display all to-do items.

1. It must display one item per line.

Remarks:

1. This exercise is based on the Simple todo list exercise from the More About Types.

1. Your goal is to rewrite that exercise using vectors instead of arrays.

2. You may reuse the code you've already implemented as a starting point.

todo_lists.ads

1package Todo_Lists is

2

3   type Todo_Item is access String;

4

5   type Todo_List is null record;

6

7   procedure Add (Todos : in out Todo_List;

8                  Item  : String);

9

10   procedure Display (Todos : Todo_List);

11

12end Todo_Lists;

todo_lists.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Todo_Lists is

4

5   procedure Add (Todos : in out Todo_List;

6                  Item  : String) is

7   begin

8      null;

9   end Add;

10

11   procedure Display (Todos : Todo_List) is

12   begin

13      Put_Line ("TO-DO LIST");

14   end Display;

15

16end Todo_Lists;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Todo_Lists;        use Todo_Lists;

5

6procedure Main is

7   type Test_Case_Index is

8     (Todo_List_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11      T : Todo_List;

12   begin

13      case TC is

14         when Todo_List_Chk =>

15            Add (T, "Buy milk");

16            Add (T, "Buy tea");

17            Add (T, "Buy present");

18            Add (T, "Buy tickets");

19            Add (T, "Pay electricity bill");

20            Add (T, "Schedule dentist appointment");

21            Add (T, "Call sister");

22            Add (T, "Revise spreasheet");

23            Add (T, "Edit entry page");

24            Add (T, "Select new design");

25            Add (T, "Create upgrade plan");

26            Display (T);

27      end case;

28   end Check;

29

30begin

31   if Argument_Count < 1 then

32      Put_Line ("ERROR: missing arguments! Exiting...");

33      return;

34   elsif Argument_Count > 1 then

35      Put_Line ("Ignoring additional arguments...");

36   end if;

37

38   Check (Test_Case_Index'Value (Argument (1)));

39end Main;

List of unique integers

Goal: create function that removes duplicates from and orders a collection of elements.

Steps:

1. Implement package Ops.

1. Declare the Int_Array type.

2. Declare the Integer_Sets type.

3. Implement the Get_Unique function that returns a set.

4. Implement the Get_Unique function that returns an array of integer values.

Requirements:

1. The Int_Array type is an unconstrained array of positive range.

2. The Integer_Sets package is an instantiation of the Ordered_Sets package for the Integer type.

3. The Get_Unique function must remove duplicates from an input array of integer values and order the elements.

1. For example:

- if the input array contains (7, 7, 1)

- the function must return (1, 7).

2. You must implement this function by using sets from the Ordered_Sets package.

3. Get_Unique must be implemented in two versions:

- one version that returns a set — Set type from the Ordered_Sets package.

- one version that returns an array of integer values — Int_Array type.

Remarks:

1. Sets — as the one found in the generic Ordered_Sets package — are useful for quickly and easily creating an algorithm that removes duplicates from a list of elements.

ops.ads

1with Ada.Containers.Ordered_Sets;

2

3package Ops is

4

5   --  type Int_Array is ...

6

7   --  package Integer_Sets is ...

8

9   subtype Int_Set is Integer_Sets.Set;

10

11   function Get_Unique (A : Int_Array) return Int_Set;

12

13   function Get_Unique (A : Int_Array) return Int_Array;

14

15end Ops;

ops.adb

1package body Ops is

2

3   function Get_Unique (A : Int_Array) return Int_Set is

4   begin

5      null;

6   end Get_Unique;

7

8   function Get_Unique (A : Int_Array) return Int_Array is

9   begin

10      null;

11   end Get_Unique;

12

13end Ops;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4with Ops;                     use Ops;

5

6procedure Main is

7   type Test_Case_Index is

8     (Get_Unique_Set_Chk,

9      Get_Unique_Array_Chk);

10

11   procedure Check (TC : Test_Case_Index;

12                    A  : Int_Array) is

13

14      procedure Display_Unique_Set (A : Int_Array) is

15         S  : constant Int_Set := Get_Unique (A);

16      begin

17         for E of S loop

18            Put_Line (Integer'Image (E));

19         end loop;

20      end Display_Unique_Set;

21

22      procedure Display_Unique_Array (A : Int_Array) is

23         AU : constant Int_Array := Get_Unique (A);

24      begin

25         for E of AU loop

26            Put_Line (Integer'Image (E));

27         end loop;

28      end Display_Unique_Array;

29

30   begin

31      case TC is

32         when Get_Unique_Set_Chk   => Display_Unique_Set (A);

33         when Get_Unique_Array_Chk => Display_Unique_Array (A);

34      end case;

35   end Check;

36

37begin

38   if Argument_Count < 3 then

39      Put_Line ("ERROR: missing arguments! Exiting...");

40      return;

41   else

42      declare

43         A : Int_Array (1 .. Argument_Count - 1);

44      begin

45         for I in A'Range loop

46            A (I) := Integer'Value (Argument (1 + I));

47         end loop;

48         Check (Test_Case_Index'Value (Argument (1)), A);

49      end;

50   end if;

51end Main;

Footnotes

Standard library: Dates & Times

Holocene calendar

Goal: create a function that returns the year in the Holocene calendar.

Steps:

1. Implement the To_Holocene_Year function.

Requirements:

1. The To_Holocene_Year extracts the year from a time object (Time type) and returns the corresponding year for the Holocene calendar#1.

1. For positive (AD) years, the Holocene year is calculated by adding 10,000 to the year number.

Remarks:

1. In this exercise, we don't deal with BC years.

2. Note that the year component of the Time type from the Ada.Calendar package is limited to years starting with 1901.

to_holocene_year.adb

1with Ada.Calendar; use Ada.Calendar;

2

3function To_Holocene_Year (T : Time) return Integer is

4begin

5   return 0;

6end To_Holocene_Year;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Calendar;            use Ada.Calendar;

4

5with To_Holocene_Year;

6

7procedure Main is

8   type Test_Case_Index is

9     (Holocene_Chk);

10

11   procedure Display_Holocene_Year (Y : Year_Number) is

12      HY : Integer;

13   begin

14      HY := To_Holocene_Year (Time_Of (Y, 1, 1));

15      Put_Line ("Year (Gregorian): " & Year_Number'Image (Y));

16      Put_Line ("Year (Holocene):  " & Integer'Image (HY));

17   end Display_Holocene_Year;

18

19   procedure Check (TC : Test_Case_Index) is

20   begin

21      case TC is

22         when Holocene_Chk =>

23            Display_Holocene_Year (2012);

24            Display_Holocene_Year (2020);

25      end case;

26   end Check;

27

28begin

29   if Argument_Count < 1 then

30      Put_Line ("ERROR: missing arguments! Exiting...");

31      return;

32   elsif Argument_Count > 1 then

33      Put_Line ("Ignoring additional arguments...");

34   end if;

35

36   Check (Test_Case_Index'Value (Argument (1)));

37end Main;

List of events

Goal: create a system to manage a list of events.

Steps:

1. Implement the Events package.

1. Declare the Event_Item type.

2. Declare the Event_Items type.

2. Implement the Events.Lists package.

1. Declare the Event_List type.

2. Implement the Add procedure.

3. Implement the Display procedure.

Requirements:

1. The Event_Item type (from the Events package) contains the description of an event.

1. This description shall be stored in an access-to-string type.

2. The Event_Items type stores a list of events.

1. This will be used later to represent multiple events for a specific date.

2. You shall use a vector for this type.

3. The Events.Lists package contains the subprograms that are used in the test application.

4. The Event_List type (from the Events.Lists package) maps a list of events to a specific date.

1. You must use the Event_Items type for the list of events.

2. You shall use the Time type from the Ada.Calendar package for the dates.

3. Since we expect the events to be ordered by the date, you shall use ordered maps for the Event_List type.

5. Procedure Add adds an event into the list of events for a specific date.

6. Procedure Display must display all events for each date (ordered by date) using the following format:

<event_date #1>

<description of item #1a>

<description of item #1b>

<event_date #2>

<description of item #2a>

<description of item #2b>

1. You should use the auxiliary Date_Image function — available in the body of the Events.Lists package — to display the date in the YYYY-MM-DD format.

Remarks:

1. Let's briefly illustrate the expected output of this system.

1. Consider the following example:

with Ada.Calendar;

with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

with Events.Lists;            use Events.Lists;

procedure Test is

EL : Event_List;

begin

EL.Add (Time_Of (2019, 4, 16),

"Item #2");

EL.Add (Time_Of (2019, 4, 15),

"Item #1");

EL.Add (Time_Of (2019, 4, 16),

"Item #3");

EL.Display;

end Test;

2. The expected output of the Test procedure must be:

EVENTS LIST

- 2019-04-15

- Item #1

- 2019-04-16

- Item #2

- Item #3

events.ads

1package Events is

2

3   type Event_Item is null record;

4

5   type Event_Items is null record;

6

7end Events;

events-lists.ads

1with Ada.Calendar; use Ada.Calendar;

2

3package Events.Lists is

4

5   type Event_List is tagged private;

6

7   procedure Add (Events     : in out Event_List;

8                  Event_Time :        Time;

9                  Event      :        String);

10

11   procedure Display (Events : Event_List);

12

13private

14

15   type Event_List is tagged null record;

16

17end Events.Lists;

events-lists.adb

1with Ada.Text_IO;             use Ada.Text_IO;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3

4package body Events.Lists is

5

6   procedure Add (Events     : in out Event_List;

7                  Event_Time : Time;

8                  Event      : String) is

9   begin

10      null;

11   end Add;

12

13   function Date_Image (T : Time) return String is

14      Date_Img : constant String := Image (T);

15   begin

16      return Date_Img (1 .. 10);

17   end;

18

19   procedure Display (Events : Event_List) is

20      T : Time;

21   begin

22      Put_Line ("EVENTS LIST");

23      --  You should use Date_Image (T) here!

24   end Display;

25

26end Events.Lists;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Calendar;

4with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

5

6with Events.Lists;            use Events.Lists;

7

8procedure Main is

9   type Test_Case_Index is

10     (Event_List_Chk);

11

12   procedure Check (TC : Test_Case_Index) is

13      EL : Event_List;

14   begin

15      case TC is

16         when Event_List_Chk =>

17            EL.Add (Time_Of (2018, 2, 16),

18                    "Final check");

19            EL.Add (Time_Of (2018, 2, 16),

20                    "Release");

21            EL.Add (Time_Of (2018, 12, 3),

22                    "Brother's birthday");

23            EL.Add (Time_Of (2018, 1, 1),

24                    "New Year's Day");

25            EL.Display;

26      end case;

27   end Check;

28

29begin

30   if Argument_Count < 1 then

31      Put_Line ("ERROR: missing arguments! Exiting...");

32      return;

33   elsif Argument_Count > 1 then

34      Put_Line ("Ignoring additional arguments...");

35   end if;

36

37   Check (Test_Case_Index'Value (Argument (1)));

38end Main;

Footnotes

#1

https://en.wikipedia.org/wiki/Holocene_calendar

Standard library: Numerics

Decibel Factor

Goal: implement functions to convert from Decibel values to factors and vice-versa.

Steps:

1. Implement the Decibels package.

1. Implement the To_Decibel function.

2. Implement the To_Factor function.

Requirements:

1. The subtypes Decibel and Factor are based on a floating-point type.

2. Function To_Decibel converts a multiplication factor (or ratio) to decibels.

- For the implementation, use \(20 * log_{10}(F)\), where F is the factor/ratio.

3. Function To_Factor converts a value in decibels to a multiplication factor (or ratio).

- For the implementation, use \(10^{D/20}\), where D is the value in Decibel.

Remarks:

1. The Decibel#1 is used to express the ratio of two values on a logarithmic scale.

1. For example, an increase of 6 dB corresponds roughly to a multiplication by two (or an increase by 100 % of the original value).

2. You can find the functions that you'll need for the calculation in the Ada.Numerics.Elementary_Functions package.

decibels.ads

1package Decibels is

2

3   subtype Decibel is Float;

4   subtype Factor  is Float;

5

6   function To_Decibel (F : Factor) return Decibel;

7

8   function To_Factor (D : Decibel) return Factor;

9

10end Decibels;

decibels.adb

1package body Decibels is

2

3   function To_Decibel (F : Factor) return Decibel is

4   begin

5      return 0.0;

6   end To_Decibel;

7

8   function To_Factor (D : Decibel) return Factor is

9   begin

10      return 0.0;

11   end To_Factor;

12

13end Decibels;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Decibels;         use Decibels;

5

6procedure Main is

7   type Test_Case_Index is

8     (Db_Chk,

9      Factor_Chk);

10

11   procedure Check (TC : Test_Case_Index; V : Float) is

12

13      package F_IO is new Ada.Text_IO.Float_IO (Factor);

14      package D_IO is new Ada.Text_IO.Float_IO (Decibel);

15

16      procedure Put_Decibel_Cnvt (D : Decibel) is

17         F : constant Factor := To_Factor (D);

18      begin

19         D_IO.Put (D, 0, 2, 0);

20         Put (" dB => Factor of ");

21         F_IO.Put (F, 0, 2, 0);

22         New_Line;

23      end;

24

25      procedure Put_Factor_Cnvt (F : Factor) is

26         D : constant Decibel := To_Decibel (F);

27      begin

28         Put ("Factor of ");

29         F_IO.Put (F, 0, 2, 0);

30         Put (" => ");

31         D_IO.Put (D, 0, 2, 0);

32         Put_Line (" dB");

33      end;

34   begin

35      case TC is

36         when Db_Chk =>

37            Put_Decibel_Cnvt (Decibel (V));

38         when Factor_Chk =>

39            Put_Factor_Cnvt (Factor (V));

40      end case;

41   end Check;

42

43begin

44   if Argument_Count < 2 then

45      Put_Line ("ERROR: missing arguments! Exiting...");

46      return;

47   elsif Argument_Count > 2 then

48      Put_Line ("Ignoring additional arguments...");

49   end if;

50

51   Check (Test_Case_Index'Value (Argument (1)), Float'Value (Argument (2)));

52end Main;

Root-Mean-Square

Goal: implement a function to calculate the root-mean-square of a sequence of values.

Steps:

1. Implement the Signals package.

1. Implement the Rms function.

Requirements:

1. Subtype Sig_Value is based on a floating-point type.

2. Type Signal is an unconstrained array of Sig_Value elements.

3. Function Rms calculates the RMS of a sequence of values stored in an array of type Signal.

1. See the remarks below for a description of the RMS calculation.

Remarks:

1. The root-mean-square#2 (RMS) value is an important information associated with sequences of values.

1. It's used, for example, as a measurement for signal processing.

2. It is calculated by:

1. Creating a sequence \(S\) with the square of each value of an input sequence \(S_{in}\).

2. Calculating the mean value \(M\) of the sequence \(S\).

3. Calculating the square-root \(R\) of \(M\).

3. You can optimize the algorithm above by combining steps #1 and #2 into a single step.

signals.ads

1package Signals is

2

3   subtype Sig_Value is Float;

4

5   type Signal is array (Natural range <>) of Sig_Value;

6

7   function Rms (S : Signal) return Sig_Value;

8

9end Signals;

signals.adb

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

2

3package body Signals is

4

5   function Rms (S : Signal) return Sig_Value is

6   begin

7      return 0.0;

8   end;

9

10end Signals;

signals-std.ads

1package Signals.Std is

2

3   Sample_Rate : Float := 8000.0;

4

5   function Generate_Sine (N : Positive; Freq : Float) return Signal;

6

7   function Generate_Square (N : Positive) return Signal;

8

9   function Generate_Triangular (N : Positive) return Signal;

10

11end Signals.Std;

signals-std.adb

1with Ada.Numerics;                      use Ada.Numerics;

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

3

4package body Signals.Std is

5

6   function Generate_Sine (N : Positive; Freq : Float) return Signal is

7      S : Signal (0 .. N - 1);

8   begin

9      for I in S'First .. S'Last loop

10         S (I) := 1.0 * Sin (2.0 * Pi * (Freq * Float (I) / Sample_Rate));

11      end loop;

12

13      return S;

14   end;

15

16   function Generate_Square (N : Positive) return Signal is

17      S : constant Signal (0 .. N - 1) := (others => 1.0);

18   begin

19      return S;

20   end;

21

22   function Generate_Triangular (N : Positive) return Signal is

23      S      : Signal (0 .. N - 1);

24      S_Half : constant Natural := S'Last / 2;

25   begin

26      for I in S'First .. S_Half loop

27         S (I) := 1.0 * (Float (I) / Float (S_Half));

28      end loop;

29      for I in S_Half .. S'Last loop

30         S (I) := 1.0 - (1.0 * (Float (I - S_Half) / Float (S_Half)));

31      end loop;

32

33      return S;

34   end;

35

36end Signals.Std;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4with Signals;                 use Signals;

5with Signals.Std;             use Signals.Std;

6

7procedure Main is

8   type Test_Case_Index is

9     (Sine_Signal_Chk,

10      Square_Signal_Chk,

11      Triangular_Signal_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14      package Sig_IO is new Ada.Text_IO.Float_IO (Sig_Value);

15

16      N    : constant Positive := 1024;

17      S_Si : constant Signal := Generate_Sine (N, 440.0);

18      S_Sq : constant Signal := Generate_Square (N);

19      S_Tr : constant Signal := Generate_Triangular (N + 1);

20   begin

21      case TC is

22         when Sine_Signal_Chk =>

23            Put ("RMS of Sine Signal: ");

24            Sig_IO.Put (Rms (S_Si), 0, 2, 0);

25            New_Line;

26         when Square_Signal_Chk =>

27            Put ("RMS of Square Signal: ");

28            Sig_IO.Put (Rms (S_Sq), 0, 2, 0);

29            New_Line;

30         when Triangular_Signal_Chk =>

31            Put ("RMS of Triangular Signal: ");

32            Sig_IO.Put (Rms (S_Tr), 0, 2, 0);

33            New_Line;

34      end case;

35   end Check;

36

37begin

38   if Argument_Count < 1 then

39      Put_Line ("ERROR: missing arguments! Exiting...");

40      return;

41   elsif Argument_Count > 1 then

42      Put_Line ("Ignoring additional arguments...");

43   end if;

44

45   Check (Test_Case_Index'Value (Argument (1)));

46end Main;

Rotation

Goal: use complex numbers to calculate the positions of an object in a circle after rotation.

Steps:

1. Implement the Rotation package.

1. Implement the Rotation function.

Requirements:

1. Type Complex_Points is an unconstrained array of complex values.

2. Function Rotation returns a list of positions (represented by the Complex_Points type) when dividing a circle in N equal slices.

1. See the remarks below for a more detailed explanation.

2. You must use functions from Ada.Numerics.Complex_Types to implement Rotation.

3. Subtype Angle is based on a floating-point type.

4. Type Angles is an unconstrained array of angles.

5. Function To_Angles returns a list of angles based on an input list of positions.

Remarks:

1. Complex numbers are particularly useful in computer graphics to simplify the calculation of rotations.

1. For example, let's assume you've drawn an object on your screen on position (1.0, 0.0).

2. Now, you want to move this object in a circular path — i.e. make it rotate around position (0.0, 0.0) on your screen.

- You could use sine and cosine functions to calculate each position of the path.

- However, you could also calculate the positions using complex numbers.

2. In this exercise, you'll use complex numbers to calculate the positions of an object that starts on zero degrees — on position (1.0, 0.0) — and rotates around (0.0, 0.0) for N slices of a circle.

1. For example, if we divide the circle in four slices, the object's path will consist of following points / positions:

Point #1: ( 1.0,  0.0)

Point #2: ( 0.0,  1.0)

Point #3: (-1.0,  0.0)

Point #4: ( 0.0, -1.0)

Point #5: ( 1.0,  0.0)

1. As expected, point #5 is equal to the starting point (point #1), since the object rotates around (0.0, 0.0) and returns to the starting point.

2. We can also describe this path in terms of angles. The following list presents the angles for the path on a four-sliced circle:

Point #1:    0.00 degrees

Point #2:   90.00 degrees

Point #3:  180.00 degrees

Point #4:  -90.00 degrees (= 270 degrees)

Point #5:    0.00 degrees

1. To rotate a complex number simply multiply it by a unit vector whose arg is the radian angle to be rotated: \(Z = e^\frac{2 \pi}{N}\)

rotation.ads

1with Ada.Numerics.Complex_Types;

2use  Ada.Numerics.Complex_Types;

3

4package Rotation is

5

6   type Complex_Points is array (Positive range <>) of Complex;

7

8   function Rotation (N : Positive) return Complex_Points;

9

10end Rotation;

rotation.adb

1with Ada.Numerics; use Ada.Numerics;

2

3package body Rotation is

4

5   function Rotation (N : Positive) return Complex_Points is

6      C : Complex_Points (1 .. 1) := (others => (0.0, 0.0));

7   begin

8      return C;

9   end;

10

11end Rotation;

angles.ads

1with Rotation; use Rotation;

2

3package Angles is

4

5   subtype Angle is Float;

6

7   type Angles is array (Positive range <>) of Angle;

8

9   function To_Angles (C : Complex_Points) return Angles;

10

11end Angles;

angles.adb

1with Ada.Numerics;               use Ada.Numerics;

2with Ada.Numerics.Complex_Types; use Ada.Numerics.Complex_Types;

3

4package body Angles is

5

6   function To_Angles (C : Complex_Points) return Angles is

7   begin

8      return A : Angles (C'Range) do

9         for I in A'Range loop

10            A (I) := Argument (C (I)) / Pi * 180.0;

11         end loop;

12      end return;

13   end To_Angles;

14

15end Angles;

rotation-tests.ads

1package Rotation.Tests is

2

3   procedure Test_Rotation (N : Positive);

4

5   procedure Test_Angles (N : Positive);

6

7end Rotation.Tests;

rotation-tests.adb

1with Ada.Text_IO;            use Ada.Text_IO;

2with Ada.Text_IO.Complex_IO;

3with Ada.Numerics;           use Ada.Numerics;

4

5with Angles;                 use Angles;

6

7package body Rotation.Tests is

8

9   package C_IO is new Ada.Text_IO.Complex_IO (Complex_Types);

10   package F_IO is new Ada.Text_IO.Float_IO (Float);

11

12   --

13   --  Adapt value due to floating-point inaccuracies

14   --

15

16   function Adapt (C : Complex) return Complex is

17      function Check_Zero (F : Float) return Float is

18        (if F <= 0.0 and F >= -0.01 then 0.0 else F);

19   begin

20      return C_Out : Complex := C do

21         C_Out.Re := Check_Zero (C_Out.Re);

22         C_Out.Im := Check_Zero (C_Out.Im);

23      end return;

24   end Adapt;

25

26   function Adapt (A : Angle) return Angle is

27     (if A <= -179.99 and A >= -180.01 then 180.0 else A);

28

29   procedure Test_Rotation (N : Positive) is

30      C : constant Complex_Points := Rotation (N);

31   begin

32      Put_Line ("---- Points for " & Positive'Image (N) & " slices ----");

33      for V of C loop

34         Put ("Point: ");

35         C_IO.Put (Adapt (V), 0, 1, 0);

36         New_Line;

37      end loop;

38   end Test_Rotation;

39

40   procedure Test_Angles (N : Positive) is

41      C : constant Complex_Points := Rotation (N);

42      A : constant Angles.Angles  := To_Angles (C);

43   begin

44      Put_Line ("---- Angles for " & Positive'Image (N) & " slices ----");

45      for V of A loop

46         Put ("Angle: ");

47         F_IO.Put (Adapt (V), 0, 2, 0);

48         Put_Line (" degrees");

49      end loop;

50   end Test_Angles;

51

52end Rotation.Tests;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3

4with Rotation.Tests;          use Rotation.Tests;

5

6procedure Main is

7   type Test_Case_Index is

8     (Rotation_Chk,

9      Angles_Chk);

10

11   procedure Check (TC : Test_Case_Index; N : Positive) is

12   begin

13      case TC is

14         when Rotation_Chk =>

15            Test_Rotation (N);

16         when Angles_Chk =>

17            Test_Angles (N);

18      end case;

19   end Check;

20

21begin

22   if Argument_Count < 2 then

23      Put_Line ("ERROR: missing arguments! Exiting...");

24      return;

25   elsif Argument_Count > 2 then

26      Put_Line ("Ignoring additional arguments...");

27   end if;

28

29   Check (Test_Case_Index'Value (Argument (1)), Positive'Value (Argument (2)));

30end Main;

Footnotes

#1

https://en.wikipedia.org/wiki/Decibel

#2

https://en.wikipedia.org/wiki/Root_mean_square

Standard library: Strings

Concatenation

Goal: implement functions to concatenate an array of unbounded strings.

Steps:

1. Implement the Str_Concat package.

1. Implement the Concat function for Unbounded_String.

2. Implement the Concat function for String.

Requirements:

1. The first Concat function receives an unconstrained array of unbounded strings and returns the concatenation of those strings as an unbounded string.

1. The second Concat function has the same parameters, but returns a standard string (String type).

2. Both Concat functions have the following parameters:

1. An unconstrained array of Unbounded_String strings (Unbounded_Strings type).

2. Trim_Str, a Boolean parameter indicating whether each unbounded string must be trimmed.

3. Add_Whitespace, a Boolean parameter indicating whether a whitespace shall be added between each unbounded string and the next one.

1. No whitespace shall be added after the last string of the array.

Remarks:

1. You can use the Trim function from the Ada.Strings.Unbounded package.

str_concat.ads

1with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

2

3package Str_Concat is

4

5   type Unbounded_Strings is array (Positive range <>) of Unbounded_String;

6

7   function Concat (USA            : Unbounded_Strings;

8                    Trim_Str       : Boolean;

9                    Add_Whitespace : Boolean) return Unbounded_String;

10

11   function Concat (USA            : Unbounded_Strings;

12                    Trim_Str       : Boolean;

13                    Add_Whitespace : Boolean) return String;

14

15end Str_Concat;

str_concat.adb

1with Ada.Strings; use Ada.Strings;

2

3package body Str_Concat is

4

5   function Concat (USA            : Unbounded_Strings;

6                    Trim_Str       : Boolean;

7                    Add_Whitespace : Boolean) return Unbounded_String is

8   begin

9      return "";

10   end Concat;

11

12   function Concat (USA            : Unbounded_Strings;

13                    Trim_Str       : Boolean;

14                    Add_Whitespace : Boolean) return String is

15   begin

16      return "";

17   end Concat;

18

19end Str_Concat;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;

4

5with Str_Concat;              use Str_Concat;

6

7procedure Main is

8   type Test_Case_Index is

9     (Unbounded_Concat_No_Trim_No_WS_Chk,

10      Unbounded_Concat_Trim_No_WS_Chk,

11      String_Concat_Trim_WS_Chk,

12      Concat_Single_Element);

13

14   procedure Check (TC : Test_Case_Index) is

15   begin

16      case TC is

17         when Unbounded_Concat_No_Trim_No_WS_Chk =>

18            declare

19               S : constant Unbounded_Strings := (

20                  To_Unbounded_String ("Hello"),

21                  To_Unbounded_String (" World"),

22                  To_Unbounded_String ("!"));

23            begin

24               Put_Line (To_String (Concat (S, False, False)));

25            end;

26         when Unbounded_Concat_Trim_No_WS_Chk =>

27            declare

28               S : constant Unbounded_Strings := (

29                  To_Unbounded_String (" This "),

30                  To_Unbounded_String (" _is_ "),

31                  To_Unbounded_String ("  a   "),

32                  To_Unbounded_String (" _check "));

33            begin

34               Put_Line (To_String (Concat (S, True, False)));

35            end;

36         when String_Concat_Trim_WS_Chk =>

37            declare

38               S : constant Unbounded_Strings := (

39                   To_Unbounded_String ("  This  "),

40                   To_Unbounded_String ("  is a  "),

41                   To_Unbounded_String ("  test.  "));

42            begin

43               Put_Line (Concat (S, True, True));

44            end;

45         when Concat_Single_Element =>

46            declare

47               S : constant Unbounded_Strings := (

48                   1 => To_Unbounded_String ("  Hi "));

49            begin

50               Put_Line (Concat (S, True, True));

51            end;

52      end case;

53   end Check;

54

55begin

56   if Argument_Count < 1 then

57      Put_Line ("ERROR: missing arguments! Exiting...");

58      return;

59   elsif Argument_Count > 1 then

60      Put_Line ("Ignoring additional arguments...");

61   end if;

62

63   Check (Test_Case_Index'Value (Argument (1)));

64end Main;

List of events

Goal: create a system to manage a list of events.

Steps:

1. Implement the Events package.

1. Declare the Event_Item subtype.

2. Implement the Events.Lists package.

1. Adapt the Add procedure.

2. Adapt the Display procedure.

Requirements:

1. The Event_Item type (from the Events package) contains the description of an event.

1. This description is declared as a subtype of unbounded string.

2. Procedure Add adds an event into the list of events for a specific date.

1. The declaration of E needs to be adapted to use unbounded strings.

3. Procedure Display must display all events for each date (ordered by date) using the following format:

1. The arguments to Put_Line need to be adapted to use unbounded strings.

Remarks:

1. We use the lab on the list of events from the previous chapter (Standard library: Dates & Times) as a starting point.

events.ads

1with Ada.Containers.Vectors;

2

3package Events is

4

5   --  subtype Event_Item is

6

7   package Event_Item_Containers is new

8     Ada.Containers.Vectors

9       (Index_Type   => Positive,

10        Element_Type => Event_Item);

11

12   subtype Event_Items is Event_Item_Containers.Vector;

13

14end Events;

events-lists.ads

1with Ada.Calendar;                use Ada.Calendar;

2with Ada.Containers.Ordered_Maps;

3

4package Events.Lists is

5

6   type Event_List is tagged private;

7

8   procedure Add (Events     : in out Event_List;

9                  Event_Time :        Time;

10                  Event      :        String);

11

12   procedure Display (Events : Event_List);

13

14private

15

16   package Event_Time_Item_Containers is new

17     Ada.Containers.Ordered_Maps

18       (Key_Type         => Time,

19        Element_Type     => Event_Items,

20        "="              => Event_Item_Containers."=");

21

22   type Event_List is new Event_Time_Item_Containers.Map with null record;

23

24end Events.Lists;

events-lists.adb

1with Ada.Text_IO;             use Ada.Text_IO;

2with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

3

4package body Events.Lists is

5

6   procedure Add (Events     : in out Event_List;

7                  Event_Time : Time;

8                  Event      : String) is

9      use Event_Item_Containers;

10      E : constant Event_Item := new String'(Event);

11   begin

12      if not Events.Contains (Event_Time) then

13         Events.Include (Event_Time, Empty_Vector);

14      end if;

15      Events (Event_Time).Append (E);

16   end Add;

17

18   function Date_Image (T : Time) return String is

19      Date_Img : constant String := Image (T);

20   begin

21      return Date_Img (1 .. 10);

22   end;

23

24   procedure Display (Events : Event_List) is

25      use Event_Time_Item_Containers;

26      T : Time;

27   begin

28      Put_Line ("EVENTS LIST");

29      for C in Events.Iterate loop

30         T := Key (C);

31         Put_Line ("- " & Date_Image (T));

32         for I of Events (C) loop

33            Put_Line ("    - " & I.all);

34         end loop;

35      end loop;

36   end Display;

37

38end Events.Lists;

main.adb

1with Ada.Command_Line;        use Ada.Command_Line;

2with Ada.Text_IO;             use Ada.Text_IO;

3with Ada.Calendar;

4with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;

5with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;

6

7with Events;

8with Events.Lists;            use Events.Lists;

9

10procedure Main is

11   type Test_Case_Index is

12     (Unbounded_String_Chk,

13      Event_List_Chk);

14

15   procedure Check (TC : Test_Case_Index) is

16      EL : Event_List;

17   begin

18      case TC is

19         when Unbounded_String_Chk =>

20            declare

21               S : constant Events.Event_Item := To_Unbounded_String ("Checked");

22            begin

23               Put_Line (To_String (S));

24            end;

25         when Event_List_Chk =>

26            EL.Add (Time_Of (2018, 2, 16),

27                    "Final check");

28            EL.Add (Time_Of (2018, 2, 16),

29                    "Release");

30            EL.Add (Time_Of (2018, 12, 3),

31                    "Brother's birthday");

32            EL.Add (Time_Of (2018, 1, 1),

33                    "New Year's Day");

34            EL.Display;

35      end case;

36   end Check;

37

38begin

39   if Argument_Count < 1 then

40      Put_Line ("ERROR: missing arguments! Exiting...");

41      return;

42   elsif Argument_Count > 1 then

43      Put_Line ("Ignoring additional arguments...");

44   end if;

45

46   Check (Test_Case_Index'Value (Argument (1)));

47end Main;

Footnotes

Strongly typed language

Colors

Goal: create a package to represent HTML colors in hexadecimal form and its corresponding names.

Steps:

1. Implement the Color_Types package.

1. Declare the HTML_Color enumeration.

2. Declare the Basic_HTML_Color enumeration.

3. Implement the To_Integer function.

4. Implement the To_HTML_Color function.

Requirements:

1. Enumeration HTML_Color has the following colors:

- Salmon

- Firebrick

- Red

- Darkred

- Lime

- Forestgreen

- Green

- Darkgreen

- Blue

- Mediumblue

- Darkblue

2. Enumeration Basic_HTML_Color has the following colors: Red, Green, Blue.

3. Function To_Integer converts from the HTML_Color type to the HTML color code — as integer values in hexadecimal notation.

- You can find the HTML color codes in the table below.

4. Function To_HTML_Color converts from Basic_HTML_Color to HTML_Color.

5. This is the table to convert from an HTML color to a HTML color code in hexadecimal notation:

Color

HTML color code (hexa)

Salmon

#FA8072

Firebrick

#B22222

Red

#FF0000

Darkred

#8B0000

Lime

#00FF00

Forestgreen

#228B22

Green

#008000

Darkgreen

#006400

Blue

#0000FF

Mediumblue

#0000CD

Darkblue

#00008B

Remarks:

1. In order to express the hexadecimal values above in Ada, use the following syntax: 16#<hex_value># (e.g.: 16#FFFFFF#).

2. For function To_Integer, you may use a case for this.

color_types.ads

1package Color_Types is

2

3   --  Include type declaration for HTML_Color!

4   --

5   --  type HTML_Color is [...]

6   --

7

8   --  Include function declaration for:

9   --  function To_Integer (C : HTML_Color) return Integer;

10

11   --  Include type declaration for Basic_HTML_Color!

12   --

13   --  type Basic_HTML_Color is [...]

14   --

15

16   --  Include function declaration for:

17   --  - Basic_HTML_Color => HTML_Color

18   --

19   --  function To_HTML_Color [...];

20   --

21end Color_Types;

color_types.adb

1package body Color_Types is

2

3   --  Implement the conversion from HTML_Color to Integer here!

4   --

5   --  function To_Integer (C : HTML_Color) return Integer is

6   --  begin

7   --  --  Hint: use 'case' for the HTML colors;

8   --  --        use 16#...# for the hexadecimal values.

9   --  end To_Integer;

10

11   --  Implement the conversion from Basic_HTML_Color to HTML_Color here!

12   --

13   --  function To_HTML_Color [...] is

14   --

15end Color_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3with Ada.Integer_Text_IO;

4

5with Color_Types; use Color_Types;

6

7procedure Main is

8   type Test_Case_Index is

9     (HTML_Color_Range,

10      HTML_Color_To_Integer,

11      Basic_HTML_Color_To_HTML_Color);

12

13   procedure Check (TC : Test_Case_Index) is

14   begin

15      case TC is

16         when HTML_Color_Range =>

17            for I in HTML_Color'Range loop

18               Put_Line (HTML_Color'Image (I));

19            end loop;

20         when HTML_Color_To_Integer =>

21            for I in HTML_Color'Range loop

22               Ada.Integer_Text_IO.Put (Item  => To_Integer (I),

23                                        Width => 6,

24                                        Base  => 16);

25               New_Line;

26            end loop;

27         when Basic_HTML_Color_To_HTML_Color =>

28            for I in Basic_HTML_Color'Range loop

29               Put_Line (HTML_Color'Image (To_HTML_Color (I)));

30            end loop;

31      end case;

32   end Check;

33

34begin

35   if Argument_Count < 1 then

36      Put_Line ("ERROR: missing arguments! Exiting...");

37      return;

38   elsif Argument_Count > 1 then

39      Put_Line ("Ignoring additional arguments...");

40   end if;

41

42   Check (Test_Case_Index'Value (Argument (1)));

43end Main;

Integers

Goal: implement a package with various integer types.

Steps:

1. Implement the Int_Types package.

1. Declare the integer type I_100.

2. Declare the modular type U_100.

3. Implement the To_I_100 function to convert from the U_100 type.

4. Implement the To_U_100 function to convert from the I_100 type.

5. Declare the derived type D_50.

6. Declare the subtype S_50.

7. Implement the To_D_50 function to convert from the I_100 type.

8. Implement the To_S_50 function to convert from the I_100 type.

9. Implement the To_I_100 function to convert from the D_50 type.

Requirements:

1. Types I_100 and U_100 have values between 0 and 100.

1. Type I_100 is an integer type.

2. Type U_100 is a modular type.

2. Function To_I_100 converts from the U_100 type to the I_100 type.

3. Function To_U_100 converts from the I_100 type to the U_100 type.

4. Types D_50 and S_50 have values between 10 and 50 and use I_100 as a base type.

1. D_50 is a derived type.

2. S_50 is a subtype.

5. Function To_D_50 converts from the I_100 type to the D_50 type.

6. Function To_S_50 converts from the I_100 type to the S_50 type.

7. Functions To_D_50 and To_S_50 saturate the input values if they are out of range.

- If the input is less than 10 the output should be 10.

- If the input is greater than 50 the output should be 50.

8. Function To_I_100 converts from the D_50 type to the I_100 type.

Remarks:

1. For the implementation of functions To_D_50 and To_S_50, you may use the type attributes D_50'First and D_50'Last:

1. D_50'First indicates the minimum value of the D_50 type.

2. D_50'Last indicates the maximum value of the D_50 type.

3. The same attributes are available for the S_50 type ( S_50'First and S_50'Last).

2. We could have implemented a function To_I_100 as well to convert from S_50 to I_100. However, we skip this here because explicit conversions are not needed for subtypes.

int_types.ads

1package Int_Types is

2

3   --  Include type declarations for I_100 and U_100!

4   --

5   --  type I_100 is [...]

6   --  type U_100 is [...]

7   --

8

9   function To_I_100 (V : U_100) return I_100;

10

11   function To_U_100 (V : I_100) return U_100;

12

13   --  Include type declarations for D_50 and S_50!

14   --

15   --  [...] D_50 is [...]

16   --  [...] S_50 is [...]

17   --

18

19   function To_D_50 (V : I_100) return D_50;

20

21   function To_S_50 (V : I_100) return S_50;

22

23   function To_I_100 (V : D_50) return I_100;

24

25end Int_Types;

int_types.adb

1package body Int_Types is

2

3   function To_I_100 (V : U_100) return I_100 is

4   begin

5      --  Implement the conversion from U_100 to I_100 here!

6      --

7      null;

8   end To_I_100;

9

10   function To_U_100 (V : I_100) return U_100 is

11   begin

12      --  Implement the conversion from I_100 to U_100 here!

13      --

14      null;

15   end To_U_100;

16

17   function To_D_50 (V : I_100) return D_50 is

18      Min : constant I_100 := I_100 (D_50'First);

19      Max : constant I_100 := I_100 (D_50'Last);

20   begin

21      --  Implement the conversion from I_100 to D_50 here!

22      --

23      --  Hint: using the constants above simplifies the checks needed for

24      --        this function.

25      --

26      null;

27   end To_D_50;

28

29   function To_S_50 (V : I_100) return S_50 is

30   begin

31      --  Implement the conversion from I_100 to S_50 here!

32      --

33      --  Remark: don't forget to verify whether an explicit conversion like

34      --          S_50 (V) is needed.

35      --

36      null;

37   end To_S_50;

38

39   function To_I_100 (V : D_50) return I_100 is

40   begin

41      --  Implement the conversion from I_100 to D_50 here!

42      --

43      --  Remark: don't forget to verify whether an explicit conversion like

44      --          I_100 (V) is needed.

45      --

46      null;

47   end To_I_100;

48

49end Int_Types;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Int_Types;        use Int_Types;

5

6procedure Main is

7   package I_100_IO is new Ada.Text_IO.Integer_IO (I_100);

8   package U_100_IO is new Ada.Text_IO.Modular_IO (U_100);

9   package D_50_IO  is new Ada.Text_IO.Integer_IO (D_50);

10

11   use I_100_IO;

12   use U_100_IO;

13   use D_50_IO;

14

15   type Test_Case_Index is

16     (I_100_Range,

17      U_100_Range,

18      U_100_Wraparound,

19      U_100_To_I_100,

20      I_100_To_U_100,

21      D_50_Range,

22      S_50_Range,

23      I_100_To_D_50,

24      I_100_To_S_50,

25      D_50_To_I_100,

26      S_50_To_I_100);

27

28   procedure Check (TC : Test_Case_Index) is

29   begin

30      I_100_IO.Default_Width := 1;

31      U_100_IO.Default_Width := 1;

32      D_50_IO.Default_Width  := 1;

33

34      case TC is

35         when I_100_Range =>

36            Put (I_100'First);

37            New_Line;

38            Put (I_100'Last);

39            New_Line;

40         when U_100_Range =>

41            Put (U_100'First);

42            New_Line;

43            Put (U_100'Last);

44            New_Line;

45         when U_100_Wraparound =>

46            Put (U_100'First - 1);

47            New_Line;

48            Put (U_100'Last + 1);

49            New_Line;

50         when U_100_To_I_100 =>

51            for I in U_100'Range loop

52               I_100_IO.Put (To_I_100 (I));

53               New_Line;

54            end loop;

55         when I_100_To_U_100 =>

56            for I in I_100'Range loop

57               Put (To_U_100 (I));

58               New_Line;

59            end loop;

60         when D_50_Range =>

61            Put (D_50'First);

62            New_Line;

63            Put (D_50'Last);

64            New_Line;

65         when S_50_Range =>

66            Put (S_50'First);

67            New_Line;

68            Put (S_50'Last);

69            New_Line;

70         when I_100_To_D_50 =>

71            for I in I_100'Range loop

72               Put (To_D_50 (I));

73               New_Line;

74            end loop;

75         when I_100_To_S_50 =>

76            for I in I_100'Range loop

77               Put (To_S_50 (I));

78               New_Line;

79            end loop;

80         when D_50_To_I_100 =>

81            for I in D_50'Range loop

82               Put (To_I_100 (I));

83               New_Line;

84            end loop;

85         when S_50_To_I_100 =>

86            for I in S_50'Range loop

87               Put (I);

88               New_Line;

89            end loop;

90      end case;

91   end Check;

92

93begin

94   if Argument_Count < 1 then

95      Put_Line ("ERROR: missing arguments! Exiting...");

96      return;

97   elsif Argument_Count > 1 then

98      Put_Line ("Ignoring additional arguments...");

99   end if;

100

101   Check (Test_Case_Index'Value (Argument (1)));

102end Main;

Temperatures

Goal: create a package to handle temperatures in Celsius and Kelvin.

Steps:

1. Implement the Temperature_Types package.

1. Declare the Celsius type.

2. Declare the Int_Celsius type.

3. Implement the To_Celsius function.

4. Implement the To_Int_Celsius function.

5. Declare the Kelvin type.

6. Implement the To_Celsius function to convert from the Kelvin type.

7. Implement the To_Kelvin function.

Requirements:

1. The custom floating-point types declared in Temperature_Types must use a precision of six digits.

2. Types Celsius and Int_Celsius are used for temperatures in Celsius:

1. Celsius is a floating-point type with a range between -273.15 and 5504.85.

2. Int_Celsius is an integer type with a range between -273 and 5505.

3. Functions To_Celsius and To_Int_Celsius are used for type conversion:

1. To_Celsius converts from Int_Celsius to Celsius type.

2. To_Int_Celsius converts from Celsius and Int_Celsius types:

4. Kelvin is a floating-point type for temperatures in Kelvin using a range between 0.0 and 5778.0.

5. The functions To_Celsius and To_Kelvin are used to convert between temperatures in Kelvin and Celsius.

1. In order to convert temperatures in Celsius to Kelvin, you must use the formula \(K = C + 273.15\), where:

- K is the temperature in Kelvin, and

- C is the temperature in Celsius.

Remarks:

1. When implementing the To_Celsius function for the Int_Celsius type:

1. You'll need to check for the minimum and maximum values of the input values because of the slightly different ranges.

2. You may use variables of floating-point type (Float) for intermediate values.

2. For the implementation of the functions To_Celsius and To_Kelvin (used for converting between Kelvin and Celsius), you may use a variable of floating-point type (Float) for intermediate values.

temperature_types.ads

1package Temperature_Types is

2

3   --  Include type declaration for Celsius!

4   --

5   --  Celsius is [...];

6       --  Int_Celsius is [...];

7   --

8

9   function To_Celsius (T : Int_Celsius) return Celsius;

10

11   function To_Int_Celsius (T : Celsius) return Int_Celsius;

12

13   --  Include type declaration for Kelvin!

14   --

15   --  type Kelvin is [...];

16   --

17

18   --  Include function declarations for:

19   --  - Kelvin  => Celsius

20   --  - Celsius => Kelvin

21   --

22   --  function To_Celsius [...];

23   --  function To_Kelvin  [...];

24   --

25end Temperature_Types;

temperature_types.adb

1package body Temperature_Types is

2

3   function To_Celsius (T : Int_Celsius) return Celsius is

4   begin

5      null;

6   end To_Celsius;

7

8   function To_Int_Celsius (T : Celsius) return Int_Celsius is

9   begin

10      null;

11   end To_Int_Celsius;

12

13   --  Include function implementation for:

14   --  - Kelvin  => Celsius

15   --  - Celsius => Kelvin

16   --

17   --  function To_Celsius [...] is

18   --  function To_Kelvin  [...] is

19   --

20end Temperature_Types;

main.adb

1with Ada.Command_Line;  use Ada.Command_Line;

2with Ada.Text_IO;       use Ada.Text_IO;

3

4with Temperature_Types; use Temperature_Types;

5

6procedure Main is

7   package Celsius_IO     is new Ada.Text_IO.Float_IO (Celsius);

8   package Kelvin_IO      is new Ada.Text_IO.Float_IO (Kelvin);

9   package Int_Celsius_IO is new Ada.Text_IO.Integer_IO (Int_Celsius);

10

11   use Celsius_IO;

12   use Kelvin_IO;

13   use Int_Celsius_IO;

14

15   type Test_Case_Index is

16     (Celsius_Range,

17      Celsius_To_Int_Celsius,

18      Int_Celsius_To_Celsius,

19      Kelvin_To_Celsius,

20      Celsius_To_Kelvin);

21

22   procedure Check (TC : Test_Case_Index) is

23   begin

24      Celsius_IO.Default_Fore := 1;

25      Kelvin_IO.Default_Fore  := 1;

26      Int_Celsius_IO.Default_Width := 1;

27

28      case TC is

29         when Celsius_Range =>

30            Put (Celsius'First);

31            New_Line;

32            Put (Celsius'Last);

33            New_Line;

34         when Celsius_To_Int_Celsius =>

35            Put (To_Int_Celsius (Celsius'First));

36            New_Line;

37            Put (To_Int_Celsius (0.0));

38            New_Line;

39            Put (To_Int_Celsius (Celsius'Last));

40            New_Line;

41         when Int_Celsius_To_Celsius =>

42            Put (To_Celsius (Int_Celsius'First));

43            New_Line;

44            Put (To_Celsius (0));

45            New_Line;

46            Put (To_Celsius (Int_Celsius'Last));

47            New_Line;

48         when Kelvin_To_Celsius =>

49            Put (To_Celsius (Kelvin'First));

50            New_Line;

51            Put (To_Celsius (0));

52            New_Line;

53            Put (To_Celsius (Kelvin'Last));

54            New_Line;

55         when Celsius_To_Kelvin =>

56            Put (To_Kelvin (Celsius'First));

57            New_Line;

58            Put (To_Kelvin (Celsius'Last));

59            New_Line;

60      end case;

61   end Check;

62

63begin

64   if Argument_Count < 1 then

65      Put_Line ("ERROR: missing arguments! Exiting...");

66      return;

67   elsif Argument_Count > 1 then

68      Put_Line ("Ignoring additional arguments...");

69   end if;

70

71   Check (Test_Case_Index'Value (Argument (1)));

72end Main;

Footnotes

Subprograms

Subtract procedure

Goal: write a procedure that subtracts two numbers.

Steps:

1. Complete the procedure Subtract.

Requirements:

1. Subtract performs the operation A - B.

subtract.ads

1--  Write the correct parameters for the procedure below.

2procedure Subtract;

subtract.adb

1procedure Subtract is

2begin

3   --  Implement the procedure here.

4   null;

5end Subtract;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Subtract;

5

6procedure Main is

7   type Test_Case_Index is

8     (Sub_10_1_Chk,

9      Sub_10_100_Chk,

10      Sub_0_5_Chk,

11      Sub_0_Minus_5_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14      Result : Integer;

15   begin

16      case TC is

17      when Sub_10_1_Chk =>

18         Subtract (10, 1, Result);

19         Put_Line ("Result: " & Integer'Image (Result));

20      when Sub_10_100_Chk =>

21         Subtract (10, 100, Result);

22         Put_Line ("Result: " & Integer'Image (Result));

23      when Sub_0_5_Chk =>

24         Subtract (0, 5, Result);

25         Put_Line ("Result: " & Integer'Image (Result));

26      when Sub_0_Minus_5_Chk =>

27         Subtract (0, -5, Result);

28         Put_Line ("Result: " & Integer'Image (Result));

29      end case;

30   end Check;

31

32begin

33   if Argument_Count < 1 then

34      Put_Line ("ERROR: missing arguments! Exiting...");

35      return;

36   elsif Argument_Count > 1 then

37      Put_Line ("Ignoring additional arguments...");

38   end if;

39

40   Check (Test_Case_Index'Value (Argument (1)));

41end Main;

Subtract function

Goal: write a function that subtracts two numbers.

Steps:

1. Rewrite the Subtract procedure from the previous exercise as a function.

Requirements:

1. Subtract performs the operation A - B and returns the result.

subtract.ads

1--  Write the correct signature for the function below.

2--  Don't forget to replace the keyword "procedure" by "function."

3procedure Subtract;

subtract.adb

1procedure Subtract is

2begin

3   --  Implement the function here!

4   null;

5end Subtract;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Subtract;

5

6procedure Main is

7   type Test_Case_Index is

8     (Sub_10_1_Chk,

9      Sub_10_100_Chk,

10      Sub_0_5_Chk,

11      Sub_0_Minus_5_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14      Result : Integer;

15   begin

16      case TC is

17      when Sub_10_1_Chk =>

18         Result := Subtract (10, 1);

19         Put_Line ("Result: " & Integer'Image (Result));

20      when Sub_10_100_Chk =>

21         Result := Subtract (10, 100);

22         Put_Line ("Result: " & Integer'Image (Result));

23      when Sub_0_5_Chk =>

24         Result := Subtract (0, 5);

25         Put_Line ("Result: " & Integer'Image (Result));

26      when Sub_0_Minus_5_Chk =>

27         Result := Subtract (0, -5);

28         Put_Line ("Result: " & Integer'Image (Result));

29      end case;

30   end Check;

31

32begin

33   if Argument_Count < 1 then

34      Put_Line ("ERROR: missing arguments! Exiting...");

35      return;

36   elsif Argument_Count > 1 then

37      Put_Line ("Ignoring additional arguments...");

38   end if;

39

40   Check (Test_Case_Index'Value (Argument (1)));

41end Main;

Equality function

Goal: write a function that compares two values and returns a flag.

Steps:

1. Complete the Is_Equal subprogram.

Requirements:

1. Is_Equal returns a flag as a Boolean value.

2. The flag must indicate whether the values are equal (flag is True) or not (flag is False).

is_equal.ads

1--  Write the correct signature for the function below.

2--  Don't forget to replace the keyword "procedure" by "function."

3procedure Is_Equal;

is_equal.adb

1procedure Is_Equal is

2begin

3   --  Implement the function here!

4   null;

5end Is_Equal;

main.adb

1with Ada.Command_Line;     use Ada.Command_Line;

2with Ada.Text_IO;          use Ada.Text_IO;

3

4with Is_Equal;

5

6procedure Main is

7   type Test_Case_Index is

8     (Equal_Chk,

9      Inequal_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12

13      procedure Display_Equal (A, B  : Integer;

14                               Equal : Boolean) is

15      begin

16         Put (Integer'Image (A));

17         if Equal then

18            Put (" is equal to ");

19         else

20            Put (" isn't equal to ");

21         end if;

22         Put_Line (Integer'Image (B) & ".");

23      end Display_Equal;

24

25      Result : Boolean;

26   begin

27      case TC is

28      when Equal_Chk =>

29         for I in 0 .. 10 loop

30            Result := Is_Equal (I, I);

31            Display_Equal (I, I, Result);

32         end loop;

33      when Inequal_Chk =>

34         for I in 0 .. 10 loop

35            Result := Is_Equal (I, I - 1);

36            Display_Equal (I, I - 1, Result);

37         end loop;

38      end case;

39   end Check;

40

41begin

42   if Argument_Count < 1 then

43      Put_Line ("ERROR: missing arguments! Exiting...");

44      return;

45   elsif Argument_Count > 1 then

46      Put_Line ("Ignoring additional arguments...");

47   end if;

48

49   Check (Test_Case_Index'Value (Argument (1)));

50end Main;

States

Goal: write a procedure that displays the state of a machine.

Steps:

1. Complete the procedure Display_State.

Requirements:

1. The states can be set according to the following numbers:

Number

State

0

Off

1

On: Simple Processing

2

On: Advanced Processing

2. The procedure Display_State receives the number corresponding to a state and displays the state (indicated by the table above) as a user message.

Remarks:

1. You can use a case statement to implement this procedure.

display_state.ads

1procedure Display_State (State : Integer);

display_state.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3procedure Display_State (State : Integer) is

4begin

5   null;

6end Display_State;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_State;

5

6procedure Main is

7   State : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   State := Integer'Value (Argument (1));

17

18   Display_State (State);

19end Main;

States #2

Goal: write a function that returns the state of a machine.

Steps:

1. Implement the function Get_State.

Requirements:

1. Implement same state machine as in the previous exercise.

2. Function Get_State must return the state as a string.

Remarks:

1. You can implement a function returning a string by simply using quotes in a return statement. For example:

get_hello.ads

1function Get_Hello return String;

get_hello.adb

1function Get_Hello return String is

2begin

3   return "Hello";

4end Get_Hello;

main.adb

1with Ada.Text_IO;      use Ada.Text_IO;

2with Get_Hello;

3

4procedure Main is

5   S : constant String := Get_Hello;

6begin

7   Put_Line (S);

8end Main;

2. You can reuse your previous implementation and replace it by a case expression.

1. For values that do not correspond to a state, you can simply return an empty string ("").

get_state.ads

1function Get_State (State : Integer) return String;

get_state.adb

1function Get_State (State : Integer) return String is

2begin

3   return "";

4end Get_State;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Get_State;

5

6procedure Main is

7   State : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   State := Integer'Value (Argument (1));

17

18   Put_Line (Get_State (State));

19end Main;

States #3

Goal: implement an on/off indicator for a state machine.

Steps:

1. Implement the function Is_On.

2. Implement the procedure Display_On_Off.

Requirements:

1. Implement same state machine as in the previous exercise.

2. Function Is_On returns:

- True if the machine is on;

- otherwise, it returns False.

3. Procedure Display_On_Off displays the message

- "On" if the machine is on, or

- "Off" otherwise.

4. Is_On must be called in the implementation of Display_On_Off.

Remarks:

1. You can implement both subprograms using if expressions.

is_on.ads

1function Is_On (State : Integer) return Boolean;

is_on.adb

1function Is_On (State : Integer) return Boolean is

2begin

3   return False;

4end Is_On;

display_on_off.ads

1procedure Display_On_Off (State : Integer);

display_on_off.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Is_On;

3

4procedure Display_On_Off (State : Integer) is

5begin

6   Put_Line ("");

7end Display_On_Off;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_On_Off;

5with Is_On;

6

7procedure Main is

8   State : Integer;

9begin

10   if Argument_Count < 1 then

11      Put_Line ("ERROR: missing arguments! Exiting...");

12      return;

13   elsif Argument_Count > 1 then

14      Put_Line ("Ignoring additional arguments...");

15   end if;

16

17   State := Integer'Value (Argument (1));

18

19   Display_On_Off (State);

20   Put_Line (Boolean'Image (Is_On (State)));

21end Main;

States #4

Goal: implement a procedure to update the state of a machine.

Steps:

1. Implement the procedure Set_Next.

Requirements:

1. Implement the same state machine as in the previous exercise.

2. Procedure Set_Next updates the machine's state with the next one in a circular manner:

- In most cases, the next state of N is simply the next number (N + 1).

- However, if the state is the last one (which is 2 for our machine), the next state must be the first one (in our case: 0).

Remarks:

1. You can use an if expression to implement Set_Next.

set_next.ads

1procedure Set_Next (State : in out Integer);

set_next.adb

1procedure Set_Next (State : in out Integer) is

2begin

3   null;

4end Set_Next;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Set_Next;

5

6procedure Main is

7   State : Integer;

8begin

9   if Argument_Count < 1 then

10      Put_Line ("ERROR: missing arguments! Exiting...");

11      return;

12   elsif Argument_Count > 1 then

13      Put_Line ("Ignoring additional arguments...");

14   end if;

15

16   State := Integer'Value (Argument (1));

17

18   Set_Next (State);

19   Put_Line (Integer'Image (State));

20end Main;

Footnotes

Tasking

Display Service

Goal: create a simple service that displays messages to the user.

Steps:

1. Implement the Display_Services package.

1. Declare the task type Display_Service.

2. Implement the Display entry for strings.

3. Implement the Display entry for integers.

Requirements:

1. Task type Display_Service uses the Display entry to display messages to the user.

2. There are two versions of the Display entry:

1. One that receives messages as a string parameter.

2. One that receives messages as an Integer parameter.

3. When a message is received via a Display entry, it must be displayed immediately to the user.

display_services.ads

1package Display_Services is

2

3end Display_Services;

display_services.adb

1package body Display_Services is

2

3end Display_Services;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Display_Services; use Display_Services;

5

6procedure Main is

7   type Test_Case_Index is (Display_Service_Chk);

8

9   procedure Check (TC : Test_Case_Index) is

10      Display : Display_Service;

11   begin

12      case TC is

13         when Display_Service_Chk =>

14            Display.Display ("Hello");

15            delay 0.5;

16            Display.Display ("Hello again");

17            delay 0.5;

18            Display.Display (55);

19            delay 0.5;

20      end case;

21   end Check;

22

23begin

24   if Argument_Count < 1 then

25      Put_Line ("ERROR: missing arguments! Exiting...");

26      return;

27   elsif Argument_Count > 1 then

28      Put_Line ("Ignoring additional arguments...");

29   end if;

30

31   Check (Test_Case_Index'Value (Argument (1)));

32end Main;

Event Manager

Goal: implement a simple event manager.

Steps:

1. Implement the Event_Managers package.

1. Declare the task type Event_Manager.

2. Implement the Start entry.

3. Implement the Event entry.

Requirements:

1. The event manager has a similar behavior as an alarm

1. The sole purpose of this event manager is to display the event ID at the correct time.

2. After the event ID is displayed, the task must finish.

2. The event manager (Event_Manager type) must have two entries:

1. Start, which starts the event manager with an event ID;

2. Event, which delays the task until a certain time and then displays the event ID as a user message.

3. The format of the user message displayed by the event manager is Event #<event_id>.

1. You should use Natural'Image to display the ID (as indicated in the body of the Event_Managers package below).

Remarks:

1. In the Start entry, you can use the Natural type for the ID.

2. In the Event entry, you should use the Time type from the Ada.Real_Time package for the time parameter.

3. Note that the test application below creates an array of event managers with different delays.

event_managers.ads

1package Event_Managers is

2

3end Event_Managers;

event_managers.adb

1package body Event_Managers is

2

3      --   Don't forget to display the event ID:

4      --

5      --   Put_Line ("Event #" & Natural'Image (Event_ID));

6

7end Event_Managers;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Event_Managers;   use Event_Managers;

5with Ada.Real_Time;    use Ada.Real_Time;

6

7procedure Main is

8   type Test_Case_Index is (Event_Manager_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11      Ev_Mng : array (1 .. 5) of Event_Manager;

12   begin

13      case TC is

14         when Event_Manager_Chk =>

15            for I in Ev_Mng'Range loop

16               Ev_Mng (I).Start (I);

17            end loop;

18            Ev_Mng (1).Event (Clock + Seconds (5));

19            Ev_Mng (2).Event (Clock + Seconds (3));

20            Ev_Mng (3).Event (Clock + Seconds (1));

21            Ev_Mng (4).Event (Clock + Seconds (2));

22            Ev_Mng (5).Event (Clock + Seconds (4));

23      end case;

24   end Check;

25

26begin

27   if Argument_Count < 1 then

28      Put_Line ("ERROR: missing arguments! Exiting...");

29      return;

30   elsif Argument_Count > 1 then

31      Put_Line ("Ignoring additional arguments...");

32   end if;

33

34   Check (Test_Case_Index'Value (Argument (1)));

35end Main;

Generic Protected Queue

Goal: create a queue container using a protected type.

Steps:

1. Implement the generic package Gen_Queues.

1. Declare the protected type Queue.

2. Implement the Empty function.

3. Implement the Full function.

4. Implement the Push entry.

5. Implement the Pop entry.

Requirements:

1. These are the formal parameters for the generic package Gen_Queues:

1. a formal modular type;

- This modular type should be used by the Queue to declare an array that stores the elements of the queue.

- The modulus of the modular type must correspond to the maximum number of elements of the queue.

2. the data type of the elements of the queue.

- Select a formal parameter that allows you to store elements of any data type in the queue.

2. These are the operations of the Queue type:

1. Function Empty indicates whether the queue is empty.

2. Function Full indicates whether the queue is full.

3. Entry Push stores an element in the queue.

4. Entry Pop removes an element from the queue and returns the element via output parameter.

Remarks:

1. In this exercise, we create a queue container by declaring and implementing a protected type (Queue) as part of a generic package (Gen_Queues).

2. As a bonus exercise, you can analyze the body of the Queue_Tests package and understand how the Queue type is used there.

1. In particular, the procedure Concurrent_Test implements two tasks: T_Producer and T_Consumer. They make use of the queue concurrently.

gen_queues.ads

1package Gen_Queues is

2

3end Gen_Queues;

gen_queues.adb

1package body Gen_Queues is

2

3end Gen_Queues;

queue_tests.ads

1package Queue_Tests is

2

3   procedure Simple_Test;

4

5   procedure Concurrent_Test;

6

7end Queue_Tests;

queue_tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3with Gen_Queues;

4

5package body Queue_Tests is

6

7   Max : constant := 10;

8   type Queue_Mod is mod Max;

9

10   procedure Simple_Test is

11      package Queues_Float is new Gen_Queues (Queue_Mod, Float);

12

13      Q_F : Queues_Float.Queue;

14      V   : Float;

15   begin

16      V := 10.0;

17      while not Q_F.Full loop

18         Q_F.Push (V);

19         V := V + 1.5;

20      end loop;

21

22      while not Q_F.Empty loop

23         Q_F.Pop (V);

24         Put_Line ("Value from queue: " & Float'Image (V));

25      end loop;

26   end Simple_Test;

27

28   procedure Concurrent_Test is

29      package Queues_Integer is new Gen_Queues (Queue_Mod, Integer);

30

31      Q_I : Queues_Integer.Queue;

32

33      task T_Producer;

34      task T_Consumer;

35

36      task body T_Producer is

37         V : Integer := 100;

38      begin

39         for I in 1 .. 2 * Max loop

40            Q_I.Push (V);

41            V := V + 1;

42         end loop;

43      end T_Producer;

44

45      task body T_Consumer is

46         V : Integer;

47      begin

48         delay 1.5;

49

50         while not Q_I.Empty loop

51            Q_I.Pop (V);

52            Put_Line ("Value from queue: " & Integer'Image (V));

53            delay 0.2;

54         end loop;

55      end T_Consumer;

56   begin

57      null;

58   end Concurrent_Test;

59

60end Queue_Tests;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Queue_Tests;      use Queue_Tests;

5

6procedure Main is

7   type Test_Case_Index is (Simple_Queue_Chk,

8                            Concurrent_Queue_Chk);

9

10   procedure Check (TC : Test_Case_Index) is

11

12   begin

13      case TC is

14         when Simple_Queue_Chk =>

15            Simple_Test;

16         when Concurrent_Queue_Chk =>

17            Concurrent_Test;

18      end case;

19   end Check;

20

21begin

22   if Argument_Count < 1 then

23      Put_Line ("ERROR: missing arguments! Exiting...");

24      return;

25   elsif Argument_Count > 1 then

26      Put_Line ("Ignoring additional arguments...");

27   end if;

28

29   Check (Test_Case_Index'Value (Argument (1)));

30end Main;

Footnotes

Solutions

Object-oriented programming

Simple type extension

type_extensions.ads

1package Type_Extensions is

2

3   type T_Float is tagged record

4      F : Float;

5   end record;

6

7   function Init (F : Float) return T_Float;

8

9   function Init (I : Integer) return T_Float;

10

11   function Image (T : T_Float) return String;

12

13   type T_Mixed is new T_Float with record

14      I : Integer;

15   end record;

16

17   function Init (F : Float) return T_Mixed;

18

19   function Init (I : Integer) return T_Mixed;

20

21   function Image (T : T_Mixed) return String;

22

23end Type_Extensions;

type_extensions.adb

1package body Type_Extensions is

2

3   function Init (F : Float) return T_Float is

4   begin

5      return ((F => F));

6   end Init;

7

8   function Init (I : Integer) return T_Float is

9   begin

10      return ((F => Float (I)));

11   end Init;

12

13   function Init (F : Float) return T_Mixed is

14   begin

15      return ((F => F,

16               I => Integer (F)));

17   end Init;

18

19   function Init (I : Integer) return T_Mixed is

20   begin

21      return ((F => Float (I),

22               I => I));

23   end Init;

24

25   function Image (T : T_Float) return String is

26   begin

27      return "{ F => " & Float'Image (T.F) & " }";

28   end Image;

29

30   function Image (T : T_Mixed) return String is

31   begin

32      return "{ F => " & Float'Image (T.F)

33        & ", I => " & Integer'Image (T.I) & " }";

34   end Image;

35

36end Type_Extensions;

main.adb

1with Ada.Command_Line; use Ada.Command_Line;

2with Ada.Text_IO;      use Ada.Text_IO;

3

4with Type_Extensions;  use Type_Extensions;

5

6procedure Main is

7

8   type Test_Case_Index is

9     (Type_Extension_Chk);

10

11   procedure Check (TC : Test_Case_Index) is

12      F1, F2 : T_Float;

13      M1, M2 : T_Mixed;

14   begin

15      case TC is

16      when Type_Extension_Chk =>

17         F1 := Init (2.0);

18         F2 := Init (3);

19         M1 := Init (4.0);

20         M2 := Init (5);

21

22         if M2 in T_Float'Class then

23           Put_Line ("T_Mixed is in T_Float'Class as expected");

24         end if;

25

26         Put_Line ("F1: " & Image (F1));

27         Put_Line ("F2: " & Image (F2));

28         Put_Line ("M1: " & Image (M1));

29         Put_Line ("M2: " & Image (M2));

30      end case;

31   end Check;

32

33begin

34   if Argument_Count < 1 then

35      Put_Line ("ERROR: missing arguments! Exiting...");

36      return;

37   elsif Argument_Count > 1 then

38      Put_Line ("Ignoring additional arguments...");

39   end if;

40

41   Check (Test_Case_Index'Value (Argument (1)));

42end Main;

Online Store

online_store.ads

1with Ada.Calendar; use Ada.Calendar;

2

3package Online_Store is

4

5   type Amount is delta 10.0**(-2) digits 10;

6

7   subtype Percentage is Amount range 0.0 .. 1.0;

8

9   type Member is tagged record

10      Start : Year_Number;

11   end record;

12

13   type Member_Access is access Member'Class;

14

15   function Get_Status (M : Member) return String;

16

17   function Get_Price (M : Member;

18                       P : Amount) return Amount;

19

20   type Full_Member is new Member with record

21      Discount : Percentage;

22   end record;

23

24   function Get_Status (M : Full_Member) return String;

25

26   function Get_Price (M : Full_Member;

27                       P : Amount) return Amount;

28

29end Online_Store;

online_store.adb

1package body Online_Store is

2

3   function Get_Status (M : Member) return String is

4     ("Associate Member");

5

6   function Get_Status (M : Full_Member) return String is

7     ("Full Member");

8

9   function Get_Price (M : Member;

10                       P : Amount) return Amount is (P);

11

12   function Get_Price (M : Full_Member;

13                       P : Amount) return Amount is

14     (P * (1.0 - M.Discount));

15

16end Online_Store;

online_store-tests.ads

1package Online_Store.Tests is

2

3   procedure Simple_Test;

4

5end Online_Store.Tests;

online_store-tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2

3package body Online_Store.Tests is

4

5   procedure Simple_Test is

6

7      type Member_Due_Amount is record

8         Member     : Member_Access;

9         Due_Amount : Amount;

10      end record;

11

12      function Get_Price (MA : Member_Due_Amount) return Amount is

13      begin

14         return MA.Member.Get_Price (MA.Due_Amount);

15      end Get_Price;

16

17      type Member_Due_Amounts is array (Positive range <>) of Member_Due_Amount;

18

19      DB : constant Member_Due_Amounts (1 .. 4)

20        := ((Member     => new Member'(Start => 2010),

21             Due_Amount => 250.0),

22            (Member     => new Full_Member'(Start    => 1998,

23                                            Discount => 0.1),

24             Due_Amount => 160.0),

25            (Member     => new Full_Member'(Start    => 1987,

26                                            Discount => 0.2),

27             Due_Amount => 400.0),

28            (Member     => new Member'(Start => 2013),

29             Due_Amount => 110.0));

30   begin

31      for I in DB'Range loop

32         Put_Line ("Member #" & Positive'Image (I));

33         Put_Line ("Status: " & DB (I).Member.Get_Status);

34         Put_Line ("Since: " & Year_Number'Image (DB (I).Member.Start));

35         Put_Line ("Due Amount: " & Amount'Image (Get_Price (DB (I))));

36         Put_Line ("--------");

37      end loop;

38   end Simple_Test;

39

40end Online_Store.Tests;

main.adb

1with Ada.Command_Line;   use Ada.Command_Line;

2with Ada.Text_IO;        use Ada.Text_IO;

3

4with Online_Store;       use Online_Store;

5with Online_Store.Tests; use Online_Store.Tests;

6

7procedure Main is

8

9   type Test_Case_Index is

10     (Type_Chk,

11      Unit_Test_Chk);

12

13   procedure Check (TC : Test_Case_Index) is

14

15      function Result_Image (Result : Boolean) return String is

16        (if Result then "OK" else "not OK");

17

18   begin

19      case TC is

20      when Type_Chk =>

21         declare

22            AM : constant Member      := (Start    => 2002);

23            FM : constant Full_Member := (Start    => 1990,

24                                          Discount => 0.2);

25         begin

26            Put_Line ("Testing Status of Associate Member Type => "

27                      & Result_Image (AM.Get_Status = "Associate Member"));

28            Put_Line ("Testing Status of Full Member Type => "

29                      & Result_Image (FM.Get_Status = "Full Member"));

30            Put_Line ("Testing Discount of Associate Member Type => "

31                      & Result_Image (AM.Get_Price (100.0) = 100.0));

32            Put_Line ("Testing Discount of Full Member Type => "

33                      & Result_Image (FM.Get_Price (100.0) = 80.0));

34         end;

35         when Unit_Test_Chk =>

36            Simple_Test;

37      end case;

38   end Check;

39

40begin

41   if Argument_Count < 1 then

42      Put_Line ("ERROR: missing arguments! Exiting...");

43      return;

44   elsif Argument_Count > 1 then

45      Put_Line ("Ignoring additional arguments...");

46   end if;

47

48   Check (Test_Case_Index'Value (Argument (1)));

49end Main;

Footnotes

Training Examples

- Declarations

- Basic Types

- Statements

- Array Types

- Record Types

- Subprograms

- Expressions

- Overloading

- Library Units

- Packages

- Private Types

- Limited Types

- Program Structure

- Visibility

- Access Types

- Genericity

- Inheritance

- Polymorphism

- Exceptions

- Elaboration

- Subprogram Contracts

- Type Contracts

- Low Level Programming

- Tasking

Footnotes

Declarations

Identifiers Comments And Pragmas

identifiers_comments_and_pragmas.ads

1package Identifiers_Comments_And_Pragmas is

2

3   Spaceperson : Integer;

4   --SPACEPERSON : integer; -- identifier is a duplicate

5   Space_Person : Integer;

6   --Null : integer := 0; -- identifier is a reserved word

7   pragma Unreferenced (Spaceperson);

8   pragma Unreferenced (Space_Person);

9

10end Identifiers_Comments_And_Pragmas;

Numeric Literals

numeric_literals.ads

1package Numeric_Literals is

2

3   Simple_Integer  : constant := 3;

4   Decimal_Number  : constant := 0.25;

5   Using_Separator : constant := 1_000_000.0;

6   Octal           : constant := 8#33#;

7   Hexadecimal     : constant := 16#AAAA#;

8

9end Numeric_Literals;

Object Declarations

object_declarations.ads

1with Ada.Calendar; use Ada.Calendar;

2package Object_Declarations is

3   A    : Integer := 0;

4   B, C : Time    := Clock;

5   D    : Integer := A + 1;

6end Object_Declarations;

Named Numbers

named_numbers.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Named_Numbers is

3   Universal_Third       : constant       := 1.0 / 3.0;

4   Float_Third           : constant Float := 1.0 / 3.0;

5   Float_Value           : Float;

6   Long_Float_Value      : Long_Float;

7   Long_Long_Float_Value : Long_Long_Float;

8begin

9   Float_Value           := Universal_Third;

10   Long_Float_Value      := Universal_Third;

11   Long_Long_Float_Value := Universal_Third;

12   Put_Line (Float'Image (Float_Value));

13   Put_Line (Long_Float'Image (Long_Float_Value));

14   Put_Line (Long_Long_Float'Image (Long_Long_Float_Value));

15   Float_Value           := Float_Third;

16   Long_Float_Value      := Long_Float (Float_Third);

17   Long_Long_Float_Value := Long_Long_Float (Float_Third);

18   Put_Line (Float'Image (Float_Value));

19   Put_Line (Long_Float'Image (Long_Float_Value));

20   Put_Line (Long_Long_Float'Image (Long_Long_Float_Value));

21end Named_Numbers;

Scope And Visibility

scope_and_visibility.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Scope_And_Visibility is

3   Name : Integer;

4begin

5   Name := 1;

6   declare

7      Name : Float := 2.0;

8   begin

9      Name := Name + Float (Scope_And_Visibility.Name);

10      Put_Line (Name'Image);

11   end;

12   Put_Line (Name'Image);

13end Scope_And_Visibility;

Aspect Clauses

aspect_clauses.ads

1package Aspect_Clauses is

2   Eight_Bits : Integer range 0 .. 255 with

3      Size => 8;

4   Object : Integer with

5      Atomic;

6end Aspect_Clauses;

Footnotes

Basic Types

Discrete Numeric Types

discrete_numeric_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Discrete_Numeric_Types is

3

4   type Signed_Integer_Type is range -128 .. 127;

5   Signed_Integer : Signed_Integer_Type := 100;

6

7   type Unsigned_Integer_Type is mod 256;

8   Unsigned_Integer : Unsigned_Integer_Type := 100;

9

10begin

11

12   Signed_Integer := Signed_Integer_Type'Last;

13   Signed_Integer := Signed_Integer_Type'Succ (Signed_Integer);

14   Put_Line (Signed_Integer'Image);

15

16   Unsigned_Integer := Unsigned_Integer_Type'First;

17   Unsigned_Integer := Unsigned_Integer_Type'Pred (Unsigned_Integer);

18   Put_Line (Unsigned_Integer'Image);

19

20   Unsigned_Integer := Unsigned_Integer_Type (Signed_Integer);

21   Put_Line (Unsigned_Integer'Image);

22

23   Unsigned_Integer := Unsigned_Integer_Type'Mod (Signed_Integer);

24   Put_Line (Unsigned_Integer'Image);

25

26   declare

27      Some_String : constant String :=

28        Unsigned_Integer_Type'Image (Unsigned_Integer);

29   begin

30      Signed_Integer := Signed_Integer_Type'Value (Some_String);

31      Put_Line (Signed_Integer'Image);

32

33      Put_Line (Some_String);

34   end;

35

36end Discrete_Numeric_Types;

Discrete Enumeration Types

discrete_enumeration_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Discrete_Enumeration_Types is

3

4   type Colors_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);

5   Color : Colors_Type := Red;

6

7   type Traffic_Light_Type is (Red, Yellow, Green);

8   for Traffic_Light_Type use (1, 2, 4);

9   Stoplight : Traffic_Light_Type := Red;

10

11   type Roman_Numeral_Digit_Type is ('I', 'V', 'X', 'L', 'C', 'M');

12   Digit : Roman_Numeral_Digit_Type := 'I';

13

14   Flag : Boolean;

15

16   Position : Integer;

17

18begin

19

20   Position  := Traffic_Light_Type'Pos (Green);

21   Color     := Colors_Type'Val (Position);

22   Stoplight := Traffic_Light_Type'(Red);

23   Digit     := Roman_Numeral_Digit_Type'Succ (Digit);

24   Flag      := End_Of_Line;

25

26   Put_Line (Position'Image);

27   Put_Line (Color'Image);

28   Put_Line (Flag'Image);

29   Put_Line (Digit'Image);

30   Put_Line (Stoplight'Image);

31

32end Discrete_Enumeration_Types;

Real Types

real_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Real_Types is

3

4   Predefined_Floating_Point : constant Float := 0.0;

5

6   type Floating_Point_Type is digits 8 range -1.0e10 .. 1.0e10;

7   Floating_Point : Floating_Point_Type := 1.234e2;

8

9begin

10

11   Put_Line (Integer'Image (Floating_Point_Type'Digits));

12   Put_Line (Integer'Image (Floating_Point_Type'Base'Digits));

13   Floating_Point := Floating_Point_Type'Succ (Floating_Point);

14   Put_Line (Floating_Point_Type'Image (Floating_Point));

15   Put_Line (Predefined_Floating_Point'Image);

16

17end Real_Types;

Footnotes

Statements

Assignment Statements

assignment_statements.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Assignment_Statements is

3

4   Max_Miles : constant Integer := 20;

5

6   type Feet_T is range 0 .. Max_Miles * 5_280;

7   type Miles_T is range 0 .. Max_Miles;

8

9   Feet  : constant Feet_T := Feet_T (Line) * 1_000;

10   Miles : Miles_T         := 0;

11

12   Index1, Index2 : Miles_T range 1 .. 20;

13

14begin

15

16   -- Miles := Feet / 5_280; -- compile error

17

18   -- Max_Miles := Max_Miles + 1; -- compile error

19

20   Index1 := Miles_T (Max_Miles); -- constraint checking added

21   Index2 := Index1;    -- no constraint checking needed

22

23   Put_Line ("Index1 = " & Index1'Image);

24   Put_Line ("Index2 = " & Index2'Image);

25

26   Index1 := 0; -- run-time error

27   Put_Line ("Index1 = " & Index1'Image);

28

29end Assignment_Statements;

Conditional Statements

conditional_statements.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Conditional_Statements is

3   type Light_T is (Red, Yellow, Green);

4   A, B  : Integer          := Integer (Line);

5   Speed : Integer;

6   Light : constant Light_T := Light_T'Val (Line);

7

8begin

9   if Light = Red then

10      Speed := 0;

11   elsif Light = Green then

12      Speed := 25;

13   else

14      Speed := 50;

15   end if;

16

17   case Light is

18      when Red =>    Speed := 0;

19      when Green =>  Speed := 25;

20      when Yellow => Speed := 50;

21   end case;

22

23   case A is

24      when 1 .. 100   => B := A;

25      when -100 .. -1 => B := -A;

26      when others     => A := B;

27   end case;

28

29   Put_Line ("Speed = " & Speed'Image);

30   Put_Line ("Light = " & Light'Image);

31

32end Conditional_Statements;

Loop Statements

loop_statements.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Loop_Statements is

3   File    : File_Type;

4   Counter : Integer := 0;

5   type Light_T is (Red, Yellow, Green);

6begin

7   loop

8      if not Is_Open (File) then

9         exit;

10      end if;

11      Counter := Counter + 1;

12      exit when Is_Open (File);

13   end loop;

14

15   while Is_Open (File) loop

16      Counter := Counter - 1;

17   end loop;

18

19   for Light in Light_T loop

20      Put_Line (Light_T'Image (Light));

21   end loop;

22

23   for Counter in reverse 1 .. 10 loop

24      Put_Line (Integer'Image (Counter));

25      exit when Is_Open (File);

26   end loop;

27end Loop_Statements;

Footnotes

Array Types

Constrained Array Types

constrained_array_types.ads

1package Constrained_Array_Types is

2

3   type Array_Of_Integers_T is array (1 .. 10) of Integer;

4   type Array_Of_Bits_T is

5         array (Natural range 0 .. 31) of Boolean;

6

7   type Color_T is (Red, Green, Blue);

8   type Color_Range_T is mod 256;

9   type Rgb_T is array (Color_T) of Color_Range_T;

10

11   Ten_Integers : Array_Of_Integers_T;

12   One_Word     : Array_Of_Bits_T;

13   Color        : Rgb_T;

14

15end Constrained_Array_Types;

Unconstrained Array Types

unconstrained_array_types.ads

1package Unconstrained_Array_Types is

2

3   type Index_T is range 1 .. 100;

4   type List_T is array (Index_T range <>) of Character;

5   Wrong : List_T (0 .. 10); -- runtime error

6   Right : List_T (11 .. 20);

7

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

9   Bits8  : Array_Of_Bits_T (0 .. 7);

10   Bits16 : Array_Of_Bits_T (1 .. 16);

11

12   type Days_T is (Sun, Mon, Tues, Wed, Thu, Fri, Sat);

13   type Schedule_T is array (Days_T range <>) of Float;

14   Schedule : Schedule_T (Mon .. Fri);

15

16   Name : String (1 .. 10);

17

18   type Roman_Digit is ('I', 'V', 'X', 'L', 'C', 'D', 'M');

19   type Roman_Number is array (Natural range <>) of Roman_Digit;

20   Orwellian : constant Roman_Number := "MCMLXXXIV";

21

22end Unconstrained_Array_Types;

Attributes

attributes.adb

1procedure Attributes is

2

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

4   Bits8 : Array_Of_Bits_T (0 .. 7);

5

6   type Array_Of_Bitstrings_T is

7     array (Natural range <>, Natural range <>) of Boolean;

8   Bitstrings : Array_Of_Bitstrings_T (1 .. 10, 0 .. 16);

9

10   Value : Natural;

11

12begin

13

14   Value := 0;

15   for Index in Bits8'First .. Bits8'Last loop

16      if Bits8 (Index) then

17         Value := Value + 2**(Index - Bits8'First);

18      end if;

19   end loop;

20

21   for String_Index in Bitstrings'Range (1) loop

22      Value := 0;

23      for Bit_Index in Bitstrings'Range (2) loop

24         if Bitstrings (String_Index, Bit_Index) then

25            Value := Value + 2**(Bit_Index - Bitstrings'First (2));

26         end if;

27      end loop;

28   end loop;

29

30end Attributes;

Operations

operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Operations is

3

4   type Boolean_Array_T is array (0 .. 15) of Boolean;

5   Bool1, Bool2, Bool3 : Boolean_Array_T;

6

7   type Integer_Array_T is array (1 .. 100) of Integer;

8   Int1, Int2 : Integer_Array_T;

9

10   Str1 : String (1 .. 10) := (others => 'X');

11   Str2 : String (2 .. 9)  := (others => '-');

12

13   Flag : Boolean;

14

15begin

16

17   Bool3 := Bool1 or Bool2;

18   Flag  := Int1 > Int2;

19   Put_Line (Flag'Image);

20

21   declare

22      Str3 : String := Str1 & Str2;

23   begin

24      Str3

25        (Str3'First .. Str3'First + 1) := "**";

26      Str3 (1 .. 4)                    := Str1 (1 .. 2) & Str2 (8 .. 9);

27      Put_Line (Str3);

28   end;

29

30   if Int1 (1) in Bool3'Range then

31      Bool3 (Int1 (1)) := Int1 (1) > Int2 (1);

32      Put_Line (Boolean'Image (Bool3 (Int1 (1))));

33   end if;

34

35end Operations;

Operations Added For Ada2012

operations_added_for_ada2012.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Operations_Added_For_Ada2012 is

3

4   type Integer_Array_T is array (1 .. 10) of Integer with

5      Default_Component_Value => -1;

6   Int_Array : Integer_Array_T;

7

8   type Matrix_T is array (1 .. 3, 1 .. 3) of Integer with

9      Default_Component_Value => -1;

10   Matrix : Matrix_T;

11

12begin

13

14   for Index in Int_Array'First + 1 .. Int_Array'Last - 1 loop

15      Int_Array (Index) := Index * 10;

16   end loop;

17   for Item of Int_Array loop

18      Put_Line (Integer'Image (Item));

19   end loop;

20

21   for Index1 in Matrix_T'First (1) + 1 .. Matrix'Last (1) loop

22      for Index2 in Matrix_T'First (2) + 1 .. Matrix'Last (2) loop

23         Matrix (Index1, Index2) := Index1 * 100 + Index2;

24      end loop;

25   end loop;

26   for Item of reverse Matrix loop

27      Put_Line (Integer'Image (Item));

28   end loop;

29

30end Operations_Added_For_Ada2012;

Aggregates

aggregates.adb

1procedure Aggregates is

2

3   type Days_T is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);

4   type Working_T is array (Days_T) of Float;

5   Week : Working_T := (others => 0.0);

6

7   Start, Finish : Days_T;

8

9   type Array_T is array (Days_T range <>) of Boolean;

10   List : Array_T (Mon .. Start) := (others => False);

11

12begin

13

14   Week := (8.0, 8.0, 8.0, 8.0, 8.0, 0.0, 0.0);

15   Week := (Sat => 0.0, Sun => 0.0, Mon .. Fri => 8.0);

16   Week := (Sat | Sun => 0.0, Mon .. Fri => 8.0);

17   -- Compile error

18   -- Week := (8.0, 8.0, 8.0, 8.0, 8.0, Sat => 0.0, Sun => 0.0);

19

20   if Week = (10.0, 10.0, 10.0, 10.0, 0.0, 0.0, 0.0) then

21      null; -- four-day week

22   end if;

23

24   Week := (8.0, others => 0.0);

25   Week := (8.0, others => <>); -- Ada2012: use previously set values

26

27   -- Compile error

28   -- Week := (Week'First .. Start => 0.0, Start .. Finish => 8.0,

29   --          Finish .. Week'Last => 0.0);

30

31end Aggregates;

Footnotes

Record Types

Components Rules

components_rules.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Components_Rules is

3   type File_T is record

4      Name    : String (1 .. 12);

5      Mode    : File_Mode;

6      Size    : Integer range 0 .. 1_024;

7      Is_Open : Boolean;

8      -- Anonymous_Component : array (1 .. 3) of Integer;

9      -- Constant_Component  : constant Integer := 123;

10      -- Self_Reference      : File_T;

11   end record;

12   File : File_T;

13begin

14   File.Name    := "Filename.txt";

15   File.Mode    := In_File;

16   File.Size    := 0;

17   File.Is_Open := False;

18   Put_Line (File.Name);

19end Components_Rules;

Operations

operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Operations is

3   type Date_T is record

4      Day   : Integer range 1 .. 31;

5      Month : Positive range 1 .. 12;

6      Year  : Natural range 0 .. 2_099;

7   end record;

8   type Personal_Information_T is record

9      Name      : String (1 .. 10);

10      Birthdate : Date_T;

11   end record;

12   type Employee_Information_T is record

13      Number               : Positive;

14      Personal_Information : Personal_Information_T;

15   end record;

16   Employee : Employee_Information_T;

17begin

18   Employee.Number                              := 1_234;

19   Employee.Personal_Information.Name           := "Fred Smith";

20   Employee.Personal_Information.Birthdate.Year := 2_020;

21   Put_Line (Employee.Number'Image);

22end Operations;

Aggregates

aggregates.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Aggregates is

3

4   type Date_T is record

5      Day   : Integer range 1 .. 31;

6      Month : Positive range 1 .. 12;

7      Year  : Natural range 0 .. 2_099;

8   end record;

9   type Personal_Information_T is record

10      Name      : String (1 .. 10);

11      Birthdate : Date_T;

12   end record;

13   type Employee_Information_T is record

14      Number               : Positive;

15      Personal_Information : Personal_Information_T;

16   end record;

17   Birthdate            : Date_T;

18   Personal_Information : Personal_Information_T;

19   Employee             : Employee_Information_T;

20begin

21   Birthdate := (25, 12, 2_001);

22   Put_Line

23     (Birthdate.Year'Image & Birthdate.Month'Image & Birthdate.Day'Image);

24   Personal_Information := (Name => "Jane Smith", Birthdate => (14, 2, 2_002));

25   Put_Line

26     (Personal_Information.Birthdate.Year'Image &

27      Personal_Information.Birthdate.Month'Image &

28      Personal_Information.Birthdate.Day'Image);

29   Employee := (1_234, Personal_Information => Personal_Information);

30   Put_Line

31     (Employee.Personal_Information.Birthdate.Year'Image &

32      Employee.Personal_Information.Birthdate.Month'Image &

33      Employee.Personal_Information.Birthdate.Day'Image);

34   Birthdate := (Month => 1, others => 2);

35   Put_Line

36     (Birthdate.Year'Image & Birthdate.Month'Image & Birthdate.Day'Image);

37end Aggregates;

Default Values

default_values.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Default_Values is

3

4   type Complex is record

5      Real      : Float := -1.0;

6      Imaginary : Float := -1.0;

7   end record;

8

9   Phasor : Complex;

10   I      : constant Complex := (0.0, 1.0);

11

12begin

13   Put_Line

14     (Float'Image (Phasor.Real) & " " & Float'Image (Phasor.Imaginary) & "i");

15   Put_Line (Float'Image (I.Real) & " " & Float'Image (I.Imaginary) & "i");

16   Phasor := (12.34, others => <>);

17   Put_Line

18     (Float'Image (Phasor.Real) & " " & Float'Image (Phasor.Imaginary) & "i");

19end Default_Values;

Variant Records

variant_records.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Variant_Records is

3   type Person_Tag is (Student, Faculty);

4   type Person (Tag : Person_Tag) is -- Tag is the discriminant

5   record

6      Name : String (1 .. 10); -- Always present

7      case Tag is

8         when Student => -- 1st variant

9            Gpa  : Float range 0.0 .. 4.0;

10            Year : Integer range 1 .. 4;

11         when Faculty => -- 2nd variant

12            Pubs : Integer;

13      end case;

14   end record;

15   S : Person (Student) :=

16     (Tag => Student, Name => (others => 'S'), Gpa => 4.0, Year => 4);

17   F : Person (Faculty) :=

18     (Tag => Faculty, Name => (others => 'F'), Pubs => 10);

19begin

20   Put_Line (S.Name & " " & F.Name);

21   Put_Line (S.Gpa'Image);

22   Put_Line (S.Pubs'Image); -- run-time error

23   Put_Line (F.Pubs'Image);

24   Put_Line (F.Year'Image); -- run-time error

25end Variant_Records;

Footnotes

Subprograms

Declarations And Bodies

declarations_and_bodies.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Declarations_And_Bodies is

3

4   -- declarations

5   procedure Swap (A, B : in out Integer);

6   function Triple (X : Float) return Float;

7

8   -- bodies

9   procedure Swap (A : in out Integer; B : in out Integer) is

10      C : constant Integer := A;

11   begin

12      A := B;

13      B := C;

14   end Swap;

15   function Triple (X : Float) return Float is

16   begin

17      return X * 3.0;

18   end Triple;

19

20   function Factorial (Counter : Natural) return Natural;

21   function Factorial (Counter : Natural) return Natural is

22   begin

23      if Counter = 1 then

24         return 1;

25      else

26         return Counter * Factorial (Counter - 1);

27      end if;

28   end Factorial;

29

30   I1, I2 : Integer := 123;

31

32begin

33   Swap (I1, I2);

34   Put_Line (Float'Image (Triple (12.3)));

35   Put_Line (Natural'Image (Factorial (5)));

36

37end Declarations_And_Bodies;

Parameters

parameters.adb

1procedure Parameters is

2

3   procedure Do_Something (Formal_I : in Integer; Formal_B : out Boolean) is

4   begin

5      Formal_B := Formal_I > 0;

6   end Do_Something;

7

8   procedure All_Modes (Number : in     Integer;

9                        Value  : in out Integer;

10                        Result :    out Boolean) is

11   begin

12      Value  := Value * Number;

13      Result := Value > 0;

14   end All_Modes;

15

16   procedure Defaults (A : Integer := 1;

17                       B : Integer := 2;

18                       C : Boolean := True;

19                       D : Boolean := False) is null;

20

21   type Vector is array (Positive range <>) of Float;

22   procedure Add (Left : in out Vector; Right : Vector) is

23   begin

24      for I in Left'First .. Left'Last loop

25         Left (I) := Left (I) + Right (I);

26      end loop;

27   end Add;

28

29   Actual_I1, Actual_I2 : Integer := 0;

30   Actual_B             : Boolean;

31   Actual_V             : Vector (1 .. 100);

32

33begin

34   Do_Something (Actual_I1,

35                 Formal_B => Actual_B);

36   All_Modes (Actual_I1 + 100, Actual_I2, Actual_B);

37   -- All_Modes (Actual_I1, Actual_I2 + 100, Actual_B); -- compile error

38   Defaults (1, 2, True, False);

39   Defaults;

40   -- Defaults (1, True); -- compile error

41   Defaults (A => 1,

42             D => True);

43   Add (Actual_V (1 .. 10), Actual_V (11 .. 20));

44end Parameters;

Expression Functions

expression_functions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Expression_Functions is

3

4   function Square1 (X : Integer) return Integer is (X * 2);

5   function Square2 (X : Integer) return Integer is

6   begin

7      return X * 2;

8   end Square2;

9

10   function Square3 (X : Integer) return Integer;

11   function Square3 (X : Integer) return Integer is (X * 2);

12

13   function Square4 (X : Integer) return Integer is (X * 2);

14   -- illegal: Square4 already complete function Square4 (X : Integer) return

15   -- Integer is begin

16   --    return X * 2;

17   -- end Square4;

18

19begin

20   Put_Line (Integer'Image (Square1 (2)));

21   Put_Line (Integer'Image (Square2 (3)));

22   Put_Line (Integer'Image (Square3 (4)));

23   Put_Line (Integer'Image (Square4 (5)));

24end Expression_Functions;

Potential Pitfalls

potential_pitfalls.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Potential_Pitfalls is

3   Global_I : Integer  := 0;

4   Global_P : Positive := 1;

5   Global_S : String   := "Hello";

6

7   procedure Unassigned_Out (A : in Integer; B : out Positive) is

8   begin

9      if A > 0 then

10         B := A;

11      end if;

12   end Unassigned_Out;

13

14   function Cause_Side_Effect return Integer is

15   begin

16      Global_I := Global_I + 1;

17      return Global_I;

18   end Cause_Side_Effect;

19

20   procedure Order_Dependent_Code (X, Y : Integer) is

21   begin

22      Put_Line (Integer'Image (X) & " / " & Integer'Image (Y));

23   end Order_Dependent_Code;

24

25   procedure Aliasing (Param : in     String;

26                       I1    : in out Integer;

27                       I2    : in out Integer) is

28   begin

29      Global_S := "World";

30      I1       := I1 * 2;

31      I2       := I2 * 3;

32      Put_Line ("Aliasing string: " & Param);

33   end Aliasing;

34

35begin

36   Unassigned_Out (-1, Global_P);

37   Put_Line ("Global_P = " & Positive'Image (Global_P));

38

39   Order_Dependent_Code (Global_I, Cause_Side_Effect);

40

41   Global_P := Positive'First;

42   -- Aliasing (Global_S, Global_I, Global_I); -- compile error

43   Aliasing (Global_S, Global_I, Global_P);

44   Put_Line ("Global_S: " & Global_S);

45   Put_Line ("Global_P: " & Global_P'Image);

46end Potential_Pitfalls;

Footnotes

Expressions

Subtypes

subtypes.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Subtypes is

3   type Days_T is (Sun, Mon, Tues, Wed, Thurs, Fri, Sat);

4   subtype Weekdays_T is Days_T range Mon .. Fri;

5

6   Weekday      : Weekdays_T              := Mon;

7   Also_Weekday : Days_T range Mon .. Fri := Tues;

8   Day          : Days_T                  := Weekday;

9

10   type Matrix_T is array (Integer range <>, Integer range <>) of Integer;

11   subtype Matrix_3x3_T is Matrix_T (1 .. 3, 1 .. 3);

12   subtype Line_T is String (1 .. 80);

13

14   I : Integer := 1_234;

15   procedure Takes_Positive (P : Positive) is null;

16

17   type Tertiary_Switch is (Off, On, Neither) with

18      Default_Value => Neither;

19   subtype Toggle_Switch is Tertiary_Switch range Off .. On;

20   Safe : Toggle_Switch := Off;

21   -- Implicit : Toggle_Switch; -- compile error: out of range

22

23   pragma Unreferenced (Safe);

24

25begin

26   Also_Weekday := Day;  -- runtime error if Day is Sat or Sun

27   Put_Line (Also_Weekday'Image);

28   Day := Weekday;  -- always legal

29   I   := I - 1;

30   Takes_Positive (I); -- runtime error if I <= 0

31

32   Weekday := Weekdays_T'Last;

33   Day     := Days_T'Last;

34

35   Put_Line (Weekdays_T'Image (Weekday) & " / " & Days_T'Image (Day));

36   Put_Line (Days_T'Image (Weekdays_T'Succ (Weekday)));

37   Put_Line (Integer'Image (Matrix_3x3_T'Length (1)));

38   Put_Line (Integer'Image (Line_T'Length (1)));

39end Subtypes;

Membership Tests

membership_tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Membership_Tests is

3   subtype Index_T is Integer range 1 .. 100;

4   X : constant Integer := Integer (Line);

5   B : Boolean          := X in 1 .. 100;

6   C : Boolean          := not (X in Index_T);

7   D : Boolean          := X not in Index_T;

8

9   type Calendar_Days is (Sun, Mon, Tues, Wed, Thur, Fri, Sat);

10   subtype Weekdays is Calendar_Days range Mon .. Fri;

11   Day : Calendar_Days := Calendar_Days'Val (X);

12

13begin

14

15   if Day in Sun | Sat then

16      -- identical expressions

17      B   := Day in Mon .. Fri;

18      C   := Day in Weekdays;

19      Day := Wed;

20   elsif Day = Mon or Day = Tues then

21      D   := D and (B or C);

22      Day := Thur;

23   end if;

24

25   Put_Line (D'Image & " " & B'Image & " " & C'Image);

26   Put_Line (Day'Image);

27

28end Membership_Tests;

Slices

slices.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Slices is

3   procedure Explicit_Indices is

4      Full_Name : String (1 .. 20) := "Barney    Rubble    ";

5   begin

6      Put_Line (Full_Name);

7      Full_Name (1 .. 10) := "Betty     ";

8      Put_Line (Full_Name (1 .. 10)); -- first half of name

9      Put_Line (Full_Name (11 .. 20)); -- second half of name

10   end Explicit_Indices;

11

12   procedure Subtype_Indices is

13      subtype First_Name is Positive range 1 .. 10;

14      subtype Last_Name is Positive range 11 .. 20;

15      Full_Name : String (First_Name'First .. Last_Name'Last) :=

16        "Fred      Flintstone";

17   begin

18      Put_Line (Full_Name);

19      Full_Name (First_Name) := "Wilma     ";

20      Put_Line (Full_Name (First_Name)); -- first half of name

21      Put_Line (Full_Name (Last_Name)); -- second half of name

22   end Subtype_Indices;

23begin

24   Explicit_Indices;

25   Subtype_Indices;

26end Slices;

Conditional Expressions

conditional_expressions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Conditional_Expressions is

3

4   type Months_T is

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

6   Year : constant Integer := 2_020;

7

8   procedure If_Expression is

9      Counter : Natural := 5;

10   begin

11      while Counter > 0 loop

12         Put_Line

13           ("Self-destruct in" & Natural'Image (Counter) &

14            (if Counter = 1 then " second" else " seconds"));

15         delay 1.0;

16         Counter := Counter - 1;

17      end loop;

18      Put_Line ("Boom! (goodbye Nostromo)");

19   end If_Expression;

20

21   procedure Case_Expression is

22      Leap_Year : constant Boolean :=

23        (Year mod 4 = 0 and Year mod 100 /= 0) or else (Year mod 400 = 0);

24   begin

25      for M in Months_T loop

26         Put_Line

27           (M'Image & " => " &

28            Integer'Image

29              (case M is when Sep | Apr | Jun | Nov => 30,

30                 when Feb    => (if Leap_Year then 29 else 28),

31                 when others => 31));

32      end loop;

33   end Case_Expression;

34

35begin

36   If_Expression;

37   Case_Expression;

38end Conditional_Expressions;

Quantified Expressions

quantified_expressions.adb

1with GNAT.Random_Numbers; use GNAT.Random_Numbers;

2with Ada.Text_IO;         use Ada.Text_IO;

3procedure Quantified_Expressions is

4   Gen    : Generator;

5   Values : constant array (1 .. 10) of Integer := (others => Random (Gen));

6

7   Any_Even : constant Boolean := (for some N of Values => N mod 2 = 0);

8   All_Odd  : constant Boolean := (for all N of reverse Values => N mod 2 = 1);

9

10   function Is_Sorted return Boolean is

11     (for all K in Values'Range =>

12        K = Values'First or else Values (K - 1) <= Values (K));

13

14   function Duplicate return Boolean is

15     (for some I in Values'Range =>

16        (for some J in I + 1 .. Values'Last => Values (I) = Values (J)));

17

18begin

19   Put_Line ("Any Even: " & Boolean'Image (Any_Even));

20   Put_Line ("All Odd: " & Boolean'Image (All_Odd));

21   Put_Line ("Is_Sorted " & Boolean'Image (Is_Sorted));

22   Put_Line ("Duplicate " & Boolean'Image (Duplicate));

23end Quantified_Expressions;

Footnotes

Overloading

Enumerals And Operators

enumerals_and_operators.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Enumerals_And_Operators is

3   type Colors_T is (Blue, Yellow, Black, Green, Red);

4   type Rgb_T is (Red, Green, Blue);

5   type Stoplight_T is (Green, Yellow, Red);

6

7   Color : constant Colors_T    := Red;

8   Rgb   : constant Rgb_T       := Red;

9   Light : constant Stoplight_T := Red;

10

11   type Miles_T is digits 6;

12   type Hour_T is digits 6;

13   type Speed_T is digits 6;

14   function "/" (M : Miles_T; H : Hour_T) return Speed_T is

15      (Speed_T (Float (M) / Float (H)));

16   function "*" (Mph : Speed_T; H   : Hour_T) return Miles_T is

17      (Miles_T (Float (Mph) * Float (H)));

18

19   M   : Miles_T         := Miles_T (Col);

20   H   : constant Hour_T := Hour_T (Line);

21   Mph : Speed_T;

22

23begin

24   Put_Line (Color'Image & " " & Rgb'Image & " " & Light'Image);

25   Mph := M / H;

26   M   := Mph * H;

27   Put_Line (Mph'Image & M'Image);

28

29   Mph := "/" (M => M, H => H);

30   M := "*" (Mph, H);

31   Put_Line (Mph'Image & M'Image);

32end Enumerals_And_Operators;

Call Resolution

call_resolution.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Call_Resolution is

3   type Colors_T is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);

4   type Rgb_T is (Red, Green, Blue);

5   function Str (P : Colors_T) return String is (Colors_T'Image (P));

6   function Str (P : Rgb_T) return String is (Rgb_T'Image (P));

7   procedure Print (Color : Colors_T) is

8   begin

9      Put_Line (Str (Color));

10   end Print;

11   procedure Print (Rgb : Rgb_T) is

12   begin

13      Put_Line (Str (Rgb));

14   end Print;

15   procedure Print (P1 : Colors_T; P2 : Rgb_T) is null;

16

17begin

18   Put_Line (Str (Yellow));

19   -- Put_Line (Str (Red)); -- compile error

20   Print (Orange);

21   Print (Rgb => Red);

22   Print (Color => Blue);

23   Print (Red, Red);

24end Call_Resolution;

Visibility Issues

visibility_issues.adb

1procedure Visibility_Issues is

2   procedure Foo (I : Integer) is

3      procedure Foo (N : Natural) is null;

4   begin

5      Foo (I);

6   end Foo;

7   -- procedure Foo (N : Natural) is null; -- compile error

8begin

9   Foo (1);

10end Visibility_Issues;

User Defined Equality

user_defined_equality.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure User_Defined_Equality is

3   type Array_T is array (1 .. 10) of Integer;

4   type List_T is record

5      List  : Array_T;

6      Count : Integer := 0;

7   end record;

8

9   function "=" (L, R : List_T) return Boolean is

10   begin

11      if L.Count /= R.Count then

12         Put_Line ("Count is off");

13         return False;

14      else

15         for I in 1 .. L.Count loop

16            if L.List (I) /= R.List (I) then

17               Put_Line ("elements don't match");

18               return False;

19            end if;

20         end loop;

21      end if;

22      return True;

23   end "=";

24   L, R : List_T := (List => (others => 1), Count => 3);

25begin

26   Put_Line (Boolean'Image (L = R));

27   L.List (2) := 0;

28   Put_Line (Boolean'Image (L = R));

29   R.Count := 1;

30   Put_Line (Boolean'Image (L = R));

31end User_Defined_Equality;

Composition Of Equality

composition_of_equality.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Composition_Of_Equality is

3   type My_Integer is range -1_000 .. 1_000;

4   function "=" (L, R : My_Integer) return Boolean is

5     (False); -- for illustration purposes

6   type Record_T is tagged record

7      Field : My_Integer := 0;

8   end record;

9   type Record_List is array (My_Integer range 1 .. 10) of Record_T;

10

11   I1, I2 : constant My_Integer  := 0;

12   R1, R2 : constant Record_List := (others => (Field => 0));

13begin

14   -- uses primitive "=" => False

15   Put_Line (Boolean'Image (I1 = I2));

16   -- uses predefined "=" for components=>True

17   Put_Line (Boolean'Image (R1 = R2));

18end Composition_Of_Equality;

Footnotes

Library Units

Library Units

named_common.ads

1package Named_Common is

2   X : Integer; -- valid object for life of application

3   Y : Float;    -- valid object for life of application

4end Named_Common;

library_procedure.ads

1procedure Library_Procedure (Parameter : in out Integer);

library_procedure.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Library_Procedure (Parameter : in out Integer) is

3   -- X is visible to Library_Procedure and Nested_Procedure

4   X : constant Integer := Parameter;

5   procedure Nested_Procedure is

6      -- Y is only visible to Nested_Procedure

7      Y : constant Integer := X * 2;

8   begin

9      Parameter := X * Y;

10   end Nested_Procedure;

11begin

12   Nested_Procedure;

13   Put_Line ("parameter = " & Parameter'Image);

14end Library_Procedure;

main.adb

1with Library_Procedure;

2with Named_Common;

3procedure Main is

4begin

5   Named_Common.X := 123;

6   Library_Procedure (Named_Common.X);

7end Main;

With Clauses

base_types.ads

1with Ada.Text_IO;

2package Base_Types is

3   type Position_T is record

4      Line   : Ada.Text_IO.Positive_Count;

5      Column : Ada.Text_IO.Positive_Count;

6   end record;

7end Base_Types;

files.ads

1-- no need to "with" ada.text_io

2with Base_Types;

3package Files is

4   subtype Name_T is String (1 .. 12);

5   type File_T is record

6      Name     : Name_T                := (others => ' ');

7      Position : Base_Types.Position_T := (Line => 1, Column => 1);

8   end record;

9   function Create (Name : Name_T) return File_T;

10end Files;

files.adb

1package body Files is

2   -- "with" of base_types inherited from spec

3   Default_Position : constant Base_Types.Position_T := (1, 1);

4   function Create (Name : Name_T) return File_T is

5     (Name => Name, Position => Default_Position);

6end Files;

Footnotes

Packages

Declarations

global_data.ads

1package Global_Data is

2   Object : Integer := 100;

3   type Float_T is digits 6;

4end Global_Data;

float_stack.ads

1with Global_Data;

2package Float_Stack is

3   Max : constant Integer := Global_Data.Object;

4   procedure Push (X : in Global_Data.Float_T);

5   function Pop return Global_Data.Float_T;

6end Float_Stack;

float_stack.adb

1package body Float_Stack is

2   Local_Object : Global_Data.Float_T;

3   procedure Not_Exported is null;

4   procedure Push (X : in Global_Data.Float_T) is

5   begin

6      Not_Exported;

7      Local_Object := X;

8   end Push;

9   function Pop return Global_Data.Float_T is (Local_Object);

10end Float_Stack;

Bodies

body_not_allowed.ads

1package Body_Not_Allowed is

2   type Real is digits 12;

3   type Device_Coordinates is record

4      X, Y : Integer;

5   end record;

6   type Normalized_Coordinates is record

7      X, Y : Real range 0.0 .. 1.0;

8   end record;

9   -- nothing to implement, so no body allowed

10end Body_Not_Allowed;

body_required.ads

1package Body_Required is

2   subtype Rows is Integer range 1 .. 24;

3   subtype Columns is Integer range 1 .. 80;

4   type Position is record

5      Row : Rows    := Rows'First;

6      Col : Columns := Columns'First;

7   end record;

8   -- The following need to be defined in the body

9   procedure Move_Cursor (To : in Position);

10   procedure Home;

11end Body_Required;

body_required.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Body_Required is

3   -- This function is not visible outside this package

4   function Unsigned (Input : Integer) return String is

5      Str : constant String := Integer'Image (Input);

6   begin

7      return Str (2 .. Str'Length);

8   end Unsigned;

9   procedure Move_Cursor (To : in Position) is

10   begin

11      Put (ASCII.ESC & "I" & Unsigned(To.Row) & ";" & Unsigned(To.Col) & "H");

12   end Move_Cursor;

13   procedure Home is null; -- not yet implemented

14end Body_Required;

Executable Parts

executable_part.ads

1package Executable_Part is

2   Visible_Seed : Integer;

3   function Number return Float;

4end Executable_Part;

executable_part.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Executable_Part is

3   Hidden_Seed : Integer;

4   procedure Initialize (Seed1 : out Integer; Seed2 : out Integer) is

5   begin

6      Seed1 := Integer'First;

7      Seed2 := Integer'Last;

8   end Initialize;

9   function Number return Float is (0.0); -- not yet implemented

10begin

11   Put_Line ("Elaborating Executable_Part");

12   Initialize (Visible_Seed, Hidden_Seed);

13end Executable_Part;

force_body.ads

1package Force_Body is

2   pragma Elaborate_Body;

3   Global_Data : array (1 .. 10) of Integer;

4end Force_Body;

force_body.adb

1-- without Elaborate_Body, this is illegal

2with Ada.Text_IO; use Ada.Text_IO;

3package body Force_Body is

4begin

5   Put_Line ("Elaborating Force_Body");

6   for I in Global_Data'Range loop

7      Global_Data (I) := I * 100;

8   end loop;

9end Force_Body;

main.adb

1with Executable_Part;

2with Force_Body;

3procedure Main is

4begin

5   null;

6end Main;

Idioms

constants.ads

1package Constants is

2   Polar_Radius      : constant := 20_856_010.51;

3   Equatorial_Radius : constant := 20_926_469.20;

4   Earth_Diameter    : constant :=

5     2.0 * ((Polar_Radius + Equatorial_Radius) / 2.0);

6end Constants;

global_data.ads

1package Global_Data is

2   Longitudinal_Velocity     : Float := 0.0;

3   Longitudinal_Acceleration : Float := 0.0;

4   Lateral_Velocity          : Float := 0.0;

5   Lateral_Acceleration      : Float := 0.0;

6   Vertical_Velocity         : Float := 0.0;

7   Vertical_Acceleration     : Float := 0.0;

8end Global_Data;

related_units.ads

1package Related_Units is

2   type Vector is array (Positive range <>) of Float;

3   function "+" (L, R : Vector) return Vector;

4   function "-" (L, R : Vector) return Vector;

5end Related_Units;

related_units.adb

1package body Related_Units is

2   -- nothing is implemented yet!

3   function "+" (L, R : Vector) return Vector is (L);

4   function "-" (L, R : Vector) return Vector is (L);

5end Related_Units;

stack_abstract_data_machine.ads

1package Stack_Abstract_Data_Machine is

2   procedure Push (X : in Float);

3   procedure Pop (X : out Float);

4   function Empty return Boolean;

5   function Full return Boolean;

6end Stack_Abstract_Data_Machine;

stack_abstract_data_machine.adb

1package body Stack_Abstract_Data_Machine is

2   -- nothing is implemented yet!

3   procedure Push (X : in Float) is null;

4   procedure Pop (X : out Float) is null;

5   function Empty return Boolean is (True);

6   function Full return Boolean is (True);

7end Stack_Abstract_Data_Machine;

Footnotes

Private Types

Implementing Abstract Data Types Via Views

bounded_stack.ads

1package Bounded_Stack is

2   Max_Capacity : constant := 100;

3   type Stack_T is private;

4   procedure Push (This : in out Stack_T; Item : Integer);

5   procedure Pop (This : in out Stack_T; Item : out Integer);

6   function Is_Empty (This : Stack_T) return Boolean;

7private

8   type List_T is array (1 .. Max_Capacity) of Integer;

9   type Stack_T is record

10      List : List_T;

11      Top  : Integer range 0 .. Max_Capacity := 0;

12   end record;

13end Bounded_Stack;

bounded_stack.adb

1package body Bounded_Stack is

2   procedure Push (This : in out Stack_T; Item : Integer) is

3   begin

4      This.Top             := This.Top + 1;

5      This.List (This.Top) := Item;

6   end Push;

7   procedure Pop (This : in out Stack_T; Item : out Integer) is

8   begin

9      Item     := This.List (This.Top);

10      This.Top := This.Top - 1;

11   end Pop;

12   function Is_Empty (This : Stack_T) return Boolean is (This.Top = 0);

13end Bounded_Stack;

main.adb

1with Ada.Text_IO;   use Ada.Text_IO;

2with Bounded_Stack; use Bounded_Stack;

3procedure Main is

4   Stack : Stack_T;

5   Item  : Integer;

6begin

7   Push (Stack, 42);

8   Put_Line (Boolean'Image (Is_Empty (Stack)));

9   Pop (Stack, Item);

10   --Put_Line (Integer'Image (Stack.Top)); -- compile error

11   Put_Line (Boolean'Image (Is_Empty (Stack)));

12   Put_Line (Item'Image);

13end Main;

Private Part Construction

sets.ads

1package Sets is

2   type Set_T is private;

3   Null_Set : constant Set_T;

4   type Days_T is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);

5   procedure Add (This : in out Set_T; Day : Days_T);

6   procedure Remove (This : in out Set_T; Day : Days_T);

7   function Str (This : Set_T) return String;

8private

9   function Length (This : Set_T) return Natural;

10   type Set_T is array (Days_T) of Boolean;

11   Null_Set : constant Set_T := (others => False);

12end Sets;

sets.adb

1package body Sets is

2   procedure Add (This : in out Set_T; Day : Days_T) is

3   begin

4      This (Day) := True;

5   end Add;

6   procedure Remove (This : in out Set_T; Day : Days_T) is null;

7   function Str (This : Set_T) return String is

8      Ret_Val : String (1 .. Length (This) * 4) := (others => ' ');

9      Pos     : Natural                         := 1;

10   begin

11      for D in This'Range loop

12         if This (D) then

13            Ret_Val (Pos .. Pos + 2) := D'Image;

14            Pos                      := Pos + 4;

15         end if;

16      end loop;

17      return Ret_Val;

18   end Str;

19   function Length (This : Set_T) return Natural is

20      Ret_Val : Natural := 0;

21   begin

22      for D in This'Range loop

23         Ret_Val := Ret_Val + (if This (D) then 1 else 0);

24      end loop;

25      return Ret_Val;

26   end Length;

27end Sets;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Sets;        use Sets;

3procedure Main is

4   Set : Set_T := Null_Set;

5begin

6   Add (Set, Sun);

7   Add (Set, Sat);

8   Add (Set, Mon);

9   Put_Line (Str (Set));

10end Main;

Idioms

complex.ads

1package Complex is

2   type Number_T is private;

3   function Constructor (Real_Part, Imaginary_Part : Float )

4                         return Number_T;

5   procedure Constructor (This           : out Number_T;

6                          Real_Part      :     Float;

7                          Imaginary_Part :     Float);

8   function Real_Part (This : Number_T) return Float;

9   function Imaginary_Part (This : Number_T) return Float;

10   function Str (This : Number_T) return String;

11

12private

13   type Number_T is record

14      Real_Part, Imaginary_Part : Float;

15   end record;

16

17   function Constructor (Real_Part, Imaginary_Part : Float )

18                         return Number_T is

19      (Real_Part, Imaginary_Part);

20

21   function Real_Part (This : Number_T) return Float is

22     (This.Real_Part);

23   function Imaginary_Part (This : Number_T) return Float is

24     (This.Imaginary_Part);

25end Complex;

complex.adb

1package body Complex is

2   procedure Constructor (This           : out Number_T;

3                          Real_Part      :     Float;

4                          Imaginary_Part :     Float) is

5   begin

6      This := Constructor (Real_Part, Imaginary_Part);

7   end Constructor;

8

9   function Str (This : Number_T) return String is

10   begin

11      return Float'Image (Real_Part (This)) & " " &

12        Float'Image (Imaginary_Part (This)) & "i";

13   end Str;

14end Complex;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Complex;     use Complex;

3procedure Main is

4   Number : Number_T := Constructor (1.2, 3.4);

5begin

6   Put_Line (Str (Number));

7   Constructor (Number, 56.7, 8.9);

8   Put_Line (Str (Number));

9end Main;

Footnotes

Limited Types

Declarations

multiprocessor_mutex.ads

1with Interfaces;

2package Multiprocessor_Mutex is

3   subtype Id_T is String (1 .. 4);

4   -- prevent copying of a lock

5   type Limited_T is limited record

6      Flag : Interfaces.Unsigned_8;

7   end record;

8   type Also_Limited_T is record

9      Lock : Limited_T;

10      Id   : Id_T;

11   end record;

12   procedure Lock (This : in out Also_Limited_T) is null;

13   procedure Unlock (This : in out Also_Limited_T) is null;

14end Multiprocessor_Mutex;

Creating Values

multiprocessor_mutex.ads

1with Interfaces;

2package Multiprocessor_Mutex is

3   subtype Id_T is String (1 .. 4);

4   -- prevent copying of a lock

5   type Limited_T is limited record

6      Flag : Interfaces.Unsigned_8;

7   end record;

8   type Also_Limited_T is record

9      Lock : Limited_T;

10      Id   : Id_T;

11   end record;

12   procedure Lock (This : in out Also_Limited_T);

13   procedure Unlock (This : in out Also_Limited_T);

14   function Create (Flag : Interfaces.Unsigned_8;

15                    Id   : Id_T)

16                    return Also_Limited_T;

17end Multiprocessor_Mutex;

multiprocessor_mutex.adb

1package body Multiprocessor_Mutex is

2   procedure Lock (This : in out Also_Limited_T) is null;

3   procedure Unlock (This : in out Also_Limited_T) is null;

4   Global_Lock : Also_Limited_T := (Lock => (Flag => 0), Id => "GLOB");

5   function Create (Flag : Interfaces.Unsigned_8;

6                    Id   : Id_T)

7                    return Also_Limited_T is

8      Local_Lock : Also_Limited_T := (Lock => (Flag => 1), Id => "LOCA");

9   begin

10      Global_Lock.Lock.Flag := Flag;

11      Local_Lock.Id         := Id;

12      -- Compile error

13      -- return Local_Lock;

14      -- Compile error

15      -- return Global_Lock;

16      return (Lock => (Flag => Flag), Id => Id);

17   end Create;

18end Multiprocessor_Mutex;

perform_lock.adb

1with Ada.Text_IO;          use Ada.Text_IO;

2with Multiprocessor_Mutex; use Multiprocessor_Mutex;

3procedure Perform_Lock is

4   Lock1 : Also_Limited_T := (Lock => (Flag => 2), Id => "LOCK");

5   Lock2 : Also_Limited_T;

6begin

7   -- Lock2 := Create ( 3, "CREA" ); -- illegal

8   Put_Line (Lock1.Id & Lock1.Lock.Flag'Image);

9end Perform_Lock;

Extended Return Statements

multiprocessor_mutex.ads

1with Interfaces; use Interfaces;

2package Multiprocessor_Mutex is

3   subtype Id_T is String (1 .. 4);

4   -- prevent copying of a lock

5   type Limited_T is limited record

6      Flag : Interfaces.Unsigned_8;

7   end record;

8   type Also_Limited_T is record

9      Lock : Limited_T;

10      Id   : Id_T;

11   end record;

12   procedure Lock (This : in out Also_Limited_T);

13   procedure Unlock (This : in out Also_Limited_T);

14   function Create (Id : Id_T) return Also_Limited_T;

15end Multiprocessor_Mutex;

multiprocessor_mutex.adb

1package body Multiprocessor_Mutex is

2   procedure Lock (This : in out Also_Limited_T) is null;

3   procedure Unlock (This : in out Also_Limited_T) is null;

4

5   Global_Lock_Counter : Interfaces.Unsigned_8 := 0;

6   function Create (Id : Id_T) return Also_Limited_T is

7   begin

8      return Ret_Val : Also_Limited_T do

9         if Global_Lock_Counter = Interfaces.Unsigned_8'Last then

10            return;

11         end if;

12         Global_Lock_Counter := Global_Lock_Counter + 1;

13         Ret_Val.Id          := Id;

14         Ret_Val.Lock.Flag   := Global_Lock_Counter;

15      end return;

16   end Create;

17end Multiprocessor_Mutex;

perform_lock.adb

1with Ada.Text_IO;          use Ada.Text_IO;

2with Multiprocessor_Mutex; use Multiprocessor_Mutex;

3procedure Perform_Lock is

4   Lock1 : constant Also_Limited_T := Create ("One ");

5   Lock2 : constant Also_Limited_T := Create ("Two ");

6begin

7   Put_Line (Lock1.Id & Lock1.Lock.Flag'Image);

8   Put_Line (Lock2.Id & Lock2.Lock.Flag'Image);

9end Perform_Lock;

Combining Limited And Private Views

multiprocessor_mutex.ads

1with Interfaces; use Interfaces;

2package Multiprocessor_Mutex is

3   type Limited_T is limited private;

4   procedure Lock (This : in out Limited_T);

5   procedure Unlock (This : in out Limited_T);

6   function Create return Limited_T;

7private

8   type Limited_T is limited -- no internal copying allowed

9   record

10      Flag : Interfaces.Unsigned_8; -- users cannot see this

11   end record;

12end Multiprocessor_Mutex;

multiprocessor_mutex.adb

1package body Multiprocessor_Mutex is

2   procedure Lock (This : in out Limited_T) is null;

3   procedure Unlock (This : in out Limited_T) is null;

4

5   Global_Lock_Counter : Interfaces.Unsigned_8 := 0;

6   function Create return Limited_T is

7   begin

8      return Ret_Val : Limited_T do

9         Global_Lock_Counter := Global_Lock_Counter + 1;

10         Ret_Val.Flag        := Global_Lock_Counter;

11      end return;

12   end Create;

13end Multiprocessor_Mutex;

use_limited_type.ads

1with Multiprocessor_Mutex; use Multiprocessor_Mutex;

2package Use_Limited_Type is

3   type Legal is limited private;

4   type Also_Legal is limited private;

5   -- type Not_Legal is private;

6   -- type Also_Not_Legal is private;

7private

8   type Legal is record

9      S : Limited_T;

10   end record;

11   type Also_Legal is limited record

12      S : Limited_T;

13   end record;

14   -- type Not_Legal is limited record

15   --    S : Limited_T;

16   -- end record;

17   -- type Also_Not_Legal is record

18   --    S : Limited_T;

19   -- end record;

20end Use_Limited_Type;

Footnotes

Program Structure

Limited With Clauses

personnel.ads

1limited with Department;

2package Personnel is

3   type Employee_T is private;

4   procedure Assign (This : in out Employee_T; Section : in Department.Section_T);

5private

6   type Employee_T is record

7      Name        : String (1 .. 10);

8      Assigned_To : access Department.Section_T;

9   end record;

10end Personnel;

department.ads

1limited with Personnel;

2package Department is

3   type Section_T is private;

4   procedure Set_Manager (This : in out Section_T; Who : in Personnel.Employee_T);

5private

6   type Section_T is record

7      Name    : String (1 .. 10);

8      Manager : access Personnel.Employee_T;

9   end record;

10end Department;

personnel.adb

1with Department;

2package body Personnel is

3   procedure Assign (This : in out Employee_T; Section : in Department.Section_T) is

4   begin

5      This.Assigned_To.all := Section;

6   end Assign;

7end Personnel;

department.adb

1with Personnel;

2package body Department is

3   procedure Set_Manager (This : in out Section_T; Who : in Personnel.Employee_T) is

4   begin

5      This.Manager.all := Who;

6   end Set_Manager;

7end Department;

Hierarchical Library Units

complex.ads

1package Complex is

2   type Number is private;

3   function "+" (Left, Right : Number) return Number;

4   function "-" (Left, Right : Number) return Number;

5private

6   type Number is record

7      Real_Part, Imaginary_Part : Float;

8   end record;

9end Complex;

complex-utils.ads

1package Complex.Utils is

2   function To_String (C : Number) return String;

3end Complex.Utils;

complex-utils.adb

1package body Complex.Utils is

2   -- construction of "number" is visible in the child body

3   function To_String (C : Number) return String is

4     (C.Real_Part'Image & " + i" & C.Imaginary_Part'Image);

5end Complex.Utils;

complex-debug.ads

1package Complex.Debug is

2   -- "with Complex;" not needed for visibility to Number

3   procedure Print (C : Number);

4end Complex.Debug;

complex-debug.adb

1with Ada.Text_IO;

2with Complex.Utils; -- needed for visibility to "To_String"

3package body Complex.Debug is

4   procedure Print (C : Number) is

5   begin

6      -- because of parent visibility, don't need to use "Complex.Utils"

7      Ada.Text_IO.Put_Line (Utils.To_String (C));

8   end Print;

9end Complex.Debug;

complex.adb

1package body Complex is

2   function "+" (Left, Right : Number) return Number is (Left);

3   function "-" (Left, Right : Number) return Number is (Left);

4end Complex;

Visibility Limits

stack.ads

1package Stack is

2   procedure Push (Item : in Integer);

3   procedure Pop (Item : out Integer);

4private

5   Object : array (1 .. 100) of integer;

6   Top    : Natural := 0;

7end Stack;

stack-utils.ads

1package Stack.Utils is

2   function Top return Integer;

3private

4   -- Legal here, but not above "private"

5   function Top return Integer is (Object (Stack.Top));

6end Stack.Utils;

stack-child.ads

1package Stack.Child is

2   procedure Misbehave;

3   procedure Reset;

4   function Peek (Index : Natural) return Integer;

5end Stack.Child;

stack-child.adb

1package body Stack.Child is

2   procedure Misbehave is

3   begin

4      Top := 0;

5   end Misbehave;

6

7   procedure Reset is

8   begin

9      Top := 0;

10   end Reset;

11

12   function Peek (Index : Natural) return Integer is (Object (Index));

13end Stack.Child;

stack.adb

1package body Stack is

2   procedure Push (Item : in Integer) is null;

3   procedure Pop (Item : out Integer) is null;

4end Stack;

Private Children

os.ads

1package Os is

2   type File_T is private;

3   function Open (Name : String) return File_T;

4   procedure Write (File : File_T; Str : String);

5   procedure Close (File : File_T);

6private

7   type File_T is new Integer;

8end Os;

os-uart.ads

1private package Os.Uart is

2   type Device_T is private;

3   function Open (Name : String) return Device_T;

4   procedure Write (Device : Device_T; Str : String);

5   procedure Close (Device : Device_T);

6private

7   type Device_T is new Integer;

8end Os.Uart;

os-serial.ads

1private with Os.Uart; -- references only in private section

2private package Os.Serial is

3   type Comport_T is private;

4   procedure Initialize (Comport : in out Comport_T);

5private

6   type Comport_T is record

7      Device : Uart.Device_T;

8   end record;

9end Os.Serial;

os.adb

1package body Os is

2   function Open (Name : String) return File_T is (1);

3   procedure Write (File : File_T; Str : String) is null;

4   procedure Close (File : File_T) is null;

5end Os;

os-uart.adb

1package body Os.Uart is

2   function Open (Name : String) return Device_T is (1);

3   procedure Write (Device : Device_T; Str : String) is null;

4   procedure Close (Device : Device_T) is null;

5end Os.Uart;

os-serial.adb

1package body Os.Serial is

2   procedure Initialize (Comport : in out Comport_T) is null;

3end Os.Serial;

Footnotes

Visibility

Use Clauses

pkg_a.ads

1package Pkg_A is

2   Constant_A  : constant := 1;

3   Constant_Aa : constant := 11;

4   Initialized : Boolean  := False;

5end Pkg_A;

pkg_b.ads

1package Pkg_B is

2   Constant_B  : constant := 20;

3   Constant_Bb : constant := 220;

4   Initialized : Boolean  := False;

5end Pkg_B;

pkg_b-child.ads

1package Pkg_B.Child is

2   Constant_Bbb : constant := 222;

3end Pkg_B.Child;

p.ads

1with Pkg_A; use Pkg_A;

2with Pkg_B;

3with Pkg_B.Child;

4package P is

5   type Type_1 is range Constant_A .. -- visible without dot-notation

6                        Pkg_B.Constant_B; -- not visible without dot-notation

7

8   use Pkg_B;

9   -- Constant_B is now visible without dot-notation

10   type Type_2 is range Constant_Aa .. Constant_Bb;

11

12   Constant_Bb : Integer := 33; -- Constant_Bb will always be the local version

13   function Bb return Integer is (Constant_Bb);

14

15   function Is_Initialized return Boolean is

16     (Pkg_A.Initialized and Pkg_B.Initialized); -- Dot-notation to resolve ambiguity

17

18   -- we "use" Pkg_B, so Child is directly visible

19   Object : Integer := Child.Constant_Bbb;

20end P;

test.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with P;

3procedure Test is

4   A, B, C : P.Type_2 := P.Type_2'First;

5begin

6   -- C := A + B; -- illegal

7   C := P."+" (A, B); -- legal but not pretty

8   Put_Line (C'Image);

9   declare

10      use P; -- make everything visible (including operators)

11   begin

12      C := A + B; -- now legal

13      Put_Line (C'Image);

14   end;

15end Test;

Use Type Clauses

p.ads

1package P is

2   type Int1 is range 0 .. 1_000;

3   type Int2 is range 0 .. 2_000;

4   type Int3 is range 0 .. 3_000;

5   function "+" (Left  : Int1; Right : Int3) return Int3;

6   function "+" (Left  : Int2; Right : Int3) return Int3;

7end P;

test.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with P;

3procedure Test is

4   A, B, C : P.Int1 := 123;

5   use type P.Int1;

6   -- D : Int2; -- "Int2" is not visible

7   D : P.Int2 := 234;

8   E : P.Int3 := 345;

9begin

10   B := A;

11   C := A + B; -- implicit operator is visible

12   Put_Line (C'Image);

13   A := B;

14   E := A + E; -- "used" operator visible

15   Put_Line (E'Image);

16   -- E := D + E; -- illegal: operator not "used"

17   -- E := E + A; -- illegal: no matching operator

18end Test;

p.adb

1package body P is

2   function "+" (Left  : Int1; Right : Int3) return Int3 is (Int3'Last);

3   function "+" (Left  : Int2; Right : Int3) return Int3 is (Int3'Last);

4end P;

Use All Type Clauses

complex.ads

1package Complex is

2   type Number is private;

3   function "*" (Left, Right : Number) return Number;

4   function "+" (Left, Right : Number) return Number;

5   procedure Put (C : Number);

6   function Make (Real_Part, Imaginary_Part : Float) return Number;

7   procedure Non_Primitive (X : Integer);

8private

9   type Number is record

10      Real_Part      : Float;

11      Imaginary_Part : Float;

12   end record;

13end Complex;

demo_use_all_type.adb

1with Complex;

2use all type Complex.Number;

3procedure Demo_Use_All_Type is

4   A, B, C : Complex.Number;

5begin

6   -- "use all type" makes these available

7   A := Make (Real_Part      => 1.0,

8              Imaginary_Part => 0.0);

9   B := Make (Real_Part      => 1.0,

10              Imaginary_Part => 0.0);

11   C := A + B;

12   Put (C);

13   -- Non_Primitive (0); -- but not this one

14end Demo_Use_All_Type;

demo_use_type.adb

1with Complex;

2use type Complex.Number;

3procedure Demo_Use_Type is

4   A, B, C : Complex.Number;

5begin

6   -- "use type" makes this available

7   C := A + B;

8   -- but not these

9   -- A := Make (Real_Part      => 1.0,

10   --            Imaginary_Part => 0.0);

11   -- B := Make (Real_Part      => 1.0,

12   --            Imaginary_Part => 0.0);

13   -- Put (C);

14   -- Non_Primitive (0);

15end Demo_Use_Type;

demo_use.adb

1with Complex; use Complex;

2procedure Demo_Use is

3   A, B, C : Complex.Number := (Complex.Make (1.1, 2.2));

4begin

5   -- "use" makes all these available

6   C := A + B;

7   A := Make (Real_Part      => 1.0,

8              Imaginary_Part => 0.0);

9   B := Make (Real_Part      => 1.0,

10              Imaginary_Part => 0.0);

11   Put (C);

12   Non_Primitive (0);

13end Demo_Use;

complex.adb

1package body Complex is

2   function "*" (Left, Right : Number) return Number is (Left);

3   function "+" (Left, Right : Number) return Number is (Left);

4   procedure Put (C : Number) is null;

5   function Make (Real_Part, Imaginary_Part : Float) return Number is

6     ((Real_Part, Imaginary_Part));

7   procedure Non_Primitive (X : Integer) is null;

8end Complex;

Footnotes

Access Types

Pool Specific Access Types

pool_specific.ads

1package Pool_Specific is

2   type Pointed_To_T is new Integer;

3   type Access_T is access Pointed_To_T;

4   Object : Access_T := new Pointed_To_T;

5

6   type Other_Access_T is access Pointed_To_T;

7   -- Other_Object : Other_Access_T := Other_Access_T ( Object ); -- illegal

8

9   type String_Access_T is access String;

10end Pool_Specific;

use_pool_specific.adb

1with Ada.Unchecked_Deallocation;

2with Ada.Text_IO;   use Ada.Text_IO;

3with Pool_Specific; use Pool_Specific;

4procedure Use_Pool_Specific is

5   X : Access_T        := new Pointed_To_T'(123);

6   Y : String_Access_T := new String (1 .. 10);

7

8   procedure Free is new Ada.Unchecked_Deallocation (Pointed_To_T, Access_T);

9

10begin

11   Put_Line (Y.all);

12   Y := new String'("String will be long enough to hold this");

13   Put_Line (Y.all);

14   Put_Line (Pointed_To_T'Image (X.all));

15   Free (X);

16   Put_Line (Pointed_To_T'Image (X.all)); -- run-time error

17end Use_Pool_Specific;

General Access Types

general.ads

1package General is

2   type Pointed_To_T is new Integer;

3   type Access_T is access all Pointed_To_T;

4   Object : Access_T := new Pointed_To_T;

5

6   type Other_Access_T is access all Pointed_To_T;

7   Other_Object : Other_Access_T := Other_Access_T (Object);

8

9   Pointed_To : aliased Pointed_To_T := 1_234;

10

11end General;

use_general.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with General;     use General;

3procedure Use_General is

4begin

5   Object := Pointed_To'Access;

6   Put_Line (Pointed_To'Image & Pointed_To_T'Image (Object.all));

7   Pointed_To := Pointed_To + 1;

8   Put_Line (Pointed_To'Image & Pointed_To_T'Image (Object.all));

9   Object.all := Object.all * 2;

10   Put_Line (Pointed_To'Image & Pointed_To_T'Image (Object.all));

11end Use_General;

Access Types

access_types.ads

1package Access_Types is

2

3   type R is record

4      F1, F2 : Integer;

5   end record;

6   type A_Int is access Integer;

7   type A_String is access all String;

8   type A_R is access R;

9

10   V_Int    : A_Int    := new Integer;

11   V_String : A_String := new String'("abc");

12   V_R      : A_R      := new R;

13

14   procedure Do_Something;

15

16end Access_Types;

access_types.adb

1package body Access_Types is

2

3   function Local_Access_Example return Integer is

4      type String_Access is access String; -- only visible here

5      X : String_Access;

6   begin

7      X := new String'("Hello, World");

8      return X.all'Length;

9   end Local_Access_Example;

10

11   procedure Do_Something is

12   begin

13      V_Int.all    := Local_Access_Example;

14      V_String.all := "cde";

15      V_String (1) := 'z'; -- similar to V_String.all (1) := 'z';

16      V_R.all      := (0, 0);

17      V_R.F1       := 1; -- similar to V_R.all.F1 := 1;

18      V_Int        := null;

19      V_R          := null;

20   end Do_Something;

21

22end Access_Types;

Accessibility Checks

accessibility_checks.ads

1package Accessibility_Checks is

2   procedure Proc_Access;

3   procedure Proc_Unchecked_Access;

4end Accessibility_Checks;

accessibility_checks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Accessibility_Checks is

3

4   type Recursive_Record_T;

5   type Global_Access_T is access all Recursive_Record_T;

6   type Recursive_Record_T is record

7      Field : Integer;

8      Next  : Global_Access_T := null;

9   end record;

10   Global_Pointer : Global_Access_T;

11   Global_Object  : aliased Recursive_Record_T;

12   procedure Proc_Access is

13      type Local_Access_T is access all Recursive_Record_T;

14      Local_Pointer : Local_Access_T;

15      Local_Object  : aliased Recursive_Record_T;

16   begin

17      Global_Pointer := Global_Object'Access;

18      Put_Line (Integer'Image (Global_Pointer.Field));

19      -- Global_Pointer := Local_Object'Access; -- illegal

20      Global_Pointer := Local_Object'Unchecked_Access;

21      Put_Line (Integer'Image (Global_Pointer.Field));

22      Local_Pointer := Global_Object'Access;

23      Put_Line (Integer'Image (Local_Pointer.Field));

24      Local_Pointer := Local_Object'Access;

25      Put_Line (Integer'Image (Local_Pointer.Field));

26      Local_Pointer := Local_Access_T (Global_Pointer);

27      Put_Line (Integer'Image (Local_Pointer.Field));

28      -- Global_Pointer := Global_Access_T (Local_Pointer); -- illegal

29   end Proc_Access;

30

31   procedure Proc_Unchecked_Access is

32      Local_Object : aliased Recursive_Record_T;

33   begin

34      -- Global_Pointer := Local_Object'Access; -- illegal

35      Global_Pointer := Local_Object'Unchecked_Access;

36   end Proc_Unchecked_Access;

37

38end Accessibility_Checks;

Memory Management

memory_management_types.ads

1with Ada.Unchecked_Deallocation;

2package Memory_Management_Types is

3   type Integer_Access_T is access all Integer;

4   procedure Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access_T);

5end Memory_Management_Types;

memory_management_test.adb

1with Memory_Management_Types; use Memory_Management_Types;

2with Ada.Exceptions;          use Ada.Exceptions;

3with Ada.Text_IO;             use Ada.Text_IO;

4procedure Memory_Management_Test is

5

6   procedure Uninitialized_Pointer is

7      Object : Integer_Access_T;

8   begin

9      Object.all := 123;

10      Put_Line ("Object = " & Integer'Image (Object.all));

11   exception

12      when Err : others =>

13         Put_Line ("Uninitialized_Pointer error: " & Exception_Name (Err));

14   end Uninitialized_Pointer;

15

16   procedure Double_Deallocation is

17      Object : Integer_Access_T;

18   begin

19      Object := new Integer'(123);

20      Put_Line ("Object = " & Integer'Image (Object.all));

21      Free (Object);

22      Free (Object);

23   exception

24      when Err : others =>

25         Put_Line ("Double_Deallocation error: " & Exception_Name (Err));

26   end Double_Deallocation;

27

28   procedure Accessing_Deallocated_Memory is

29      Object : Integer_Access_T;

30   begin

31      Object := new Integer'(123);

32      Put_Line ("Object = " & Integer'Image (Object.all));

33      Free (Object);

34      Put_Line ("Object = " & Integer'Image (Object.all));

35   exception

36      when Err : others =>

37         Put_Line ("Accessing_Deallocated_Memory error: " & Exception_Name (Err));

38   end Accessing_Deallocated_Memory;

39

40   procedure Memory_Leak is

41      Object  : Integer_Access_T;

42   begin

43      for Counter in Integer'Range loop

44         Object  := new Integer'(Counter);

45      end loop;

46      Put_Line ("Complete" );

47   exception

48      when Err : others =>

49         Put_Line ("Memory_Leak error: " & Exception_Name (Err));

50   end Memory_Leak;

51

52begin

53   Uninitialized_Pointer;

54   Double_Deallocation;

55   Accessing_Deallocated_Memory;

56   Memory_Leak;

57end Memory_Management_Test;

Anonymous Access Types

anonymous_access_types.ads

1package Anonymous_Access_Types is

2   type Access_T is access all Integer;

3   Global : Access_T := new Integer'(123);

4

5   function F1 (Param : access Integer) return Boolean is (Param = null);

6   function F2 (Param : access Integer) return Boolean is (F1 (Param));

7

8   function F3 (Param : access Integer) return Boolean is

9     (F1 (Param) -- Param is an anonymous access type

10      or F2 (Global)); -- Global is a named access type

11end Anonymous_Access_Types;

primitives_and_access_type.ads

1package Primitives_And_Access_Type is

2   type Root_T is tagged null record;

3   type Access_Root_T is access all Root_T;

4   function Primitive_Of_Root (V : access Root_T) return Boolean is (V = null);

5   function Action_On_Access (V : Access_Root_T) return Boolean is (V = null);

6   type Child_T is new Root_T with null record;

7   type Access_Child_T is access all Child_T;

8   overriding function Primitive_Of_Root (V : access Child_T) return Boolean is

9     (False);

10   -- Illegal:

11   -- overriding function Action_On_Access (V : access_child_t_t)

12   --                                       return boolean is ( false );

13end Primitives_And_Access_Type;

anonymous_access_modifiers.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Anonymous_Access_Types;

3with Primitives_And_Access_Type;

4procedure Anonymous_Access_Modifiers is

5   Global : aliased Primitives_And_Access_Type.Root_T;

6

7   type Constant_Access_T is access constant Integer;

8   type Not_Null_Access_T is not null access Integer;

9

10   Constant_Access_Object : Constant_Access_T := new Integer'(123);

11   Not_Null_Access_Object : Not_Null_Access_T := new Integer'(345);

12

13begin

14   Put_Line (Boolean'Image (Anonymous_Access_Types.F3 (Not_Null_Access_Object)));

15   Put_Line (Boolean'Image

16        (Primitives_And_Access_Type.Primitive_Of_Root (Global'Access)));

17

18   Put_Line (Integer'Image (Not_Null_Access_Object.all));

19   Not_Null_Access_Object := new Integer'(Constant_Access_Object.all);

20   Put_Line (Integer'Image (Not_Null_Access_Object.all));

21

22   -- Constant_Access_Object.all := Not_Null_Access_Object.all; -- illegal

23   Constant_Access_Object := null; -- legal

24   Put_Line (Boolean'Image (Constant_Access_Object = null));

25end Anonymous_Access_Modifiers;

Footnotes

Genericity

Generic Data

generic_data.ads

1package Generic_Data is

2   generic

3      type Discrete_T is (<>);

4      type Integer_T is range <>;

5      type Float_T is digits <>;

6      type Indefinite_T;

7      type Tagged_T is tagged;

8      type Array_T is array (Boolean) of Integer;

9      type Access_T is access all Integer;

10      type Private_T is private;

11      type Unconstrained_T (<>) is private;

12   package Parameter_Properties is

13      procedure Do_Something ( Discrete_Param      : Discrete_T;

14                               Integer_Param       : Integer_T;

15                               Float_Param         : Float_T;

16                               Indefinite_Param    : access Indefinite_T;

17                               Tagged_Param        : Tagged_T;

18                               Array_Param         : Array_T;

19                               Access_Param        : Access_T;

20                               Private_Param       : Private_T;

21                               Unconstrained_Param : Unconstrained_T);

22   end Parameter_Properties;

23

24   generic

25      type Item_T is private;

26      type Access_Item_T is access all Item_T;

27      type Index_T is (<>);

28      type Array_T is array (Index_T range <>) of Access_Item_T;

29   package Combination is

30      procedure Add (List  : in out Array_T;

31                     Index : in     Index_T;

32                     Item  : in     Item_T);

33   end Combination;

34end Generic_Data;

generic_instances.ads

1with Types; use Types;

2with Generic_Data;

3package Generic_Instances is

4   package Parameter_Properties_Instance is new Generic_Data

5     .Parameter_Properties

6     (Boolean, Integer, Float, Indefinite_T => Hidden_T,

7      Tagged_T => Tagged_Record_T, Array_T => Boolean_Array_Of_Integers_T,

8      Access_T => Access_Integer_T, Private_T => Some_Private_T,

9      Unconstrained_T                       => String);

10

11   type Item_T is (Red, White, Blue);

12   type Access_T is access all Item_T;

13   type Index_T is range 1 .. 100;

14   type Array_T is array (Index_T range <>) of Access_T;

15   package Combination_Instance is new Generic_Data.Combination

16     (Item_T, Access_T, Index_T, Array_T);

17end Generic_Instances;

generic_data.adb

1package body Generic_Data is

2   package body Parameter_Properties is

3      procedure Do_Something ( Discrete_Param      : Discrete_T;

4                               Integer_Param       : Integer_T;

5                               Float_Param         : Float_T;

6                               Indefinite_Param    : access Indefinite_T;

7                               Tagged_Param        : Tagged_T;

8                               Array_Param         : Array_T;

9                               Access_Param        : Access_T;

10                               Private_Param       : Private_T;

11                               Unconstrained_Param : Unconstrained_T) is null;

12   end Parameter_Properties;

13

14   package body Combination is

15      procedure Add (List  : in out Array_T;

16                     Index : in     Index_T;

17                     Item  : in     Item_T) is

18      begin

19         List (Index) := new Item_T'(Item);

20      end Add;

21   end Combination;

22end Generic_Data;

types.ads

1package Types is

2   type Hidden_T;

3   type Tagged_Record_T is tagged record

4      Field : access Hidden_T;

5   end record;

6   type Hidden_T is private;

7   type Boolean_Array_Of_Integers_T is array (Boolean) of Integer;

8   type Access_Integer_T is access all Integer;

9   type Some_Private_T is private;

10private

11   type Hidden_T is new Integer;

12   type Some_Private_T is new Integer;

13end Types;

Generic Formal Data

generic_formal_data.ads

1package Generic_Formal_Data is

2   generic

3      type Variable_T is range <>;

4      Variable : in out Variable_T;

5      Increment : Variable_T;

6   package Constants_And_Variables is

7      procedure Add;

8      function Value return Variable_T is (Variable);

9   end Constants_And_Variables;

10

11   generic

12      type Type_T is (<>);

13      with procedure Print_One (Prompt : String; Value : Type_T);

14      with procedure Print_Two (Prompt : String; Value : Type_T) is null;

15      with procedure Print_Three (Prompt : String; Value : Type_T) is <>;

16   package Subprogram_Parameters is

17      procedure Print (Prompt : String; Param : Type_T);

18   end Subprogram_Parameters;

19end Generic_Formal_Data;

test_generic_formal_data.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2with Generic_Formal_Data; use Generic_Formal_Data;

3procedure Test_Generic_Formal_Data is

4   procedure Print_One (Prompt : String; Param : Integer) is

5   begin

6      Put_Line (Prompt & " - Print_One" & Param'Image);

7   end Print_One;

8   procedure Print_Two (Prompt : String; Param : Integer) is

9   begin

10      Put_Line (Prompt & " - Print_Two" & Param'Image);

11   end Print_Two;

12   procedure Print_Three (Prompt : String; Param : Integer) is

13   begin

14      Put_Line (Prompt & " - Print_Three" & Param'Image);

15   end Print_Three;

16   procedure Print_Three_Prime (Prompt : String; Param : Integer) is

17   begin

18      Put_Line (Prompt & " - Print_Three_Prime" & Param'Image);

19   end Print_Three_Prime;

20

21   Global_Object : Integer := 0;

22   package Global_Data is new Constants_And_Variables

23     (Integer, Global_Object, 111);

24

25   package Print_1 is new Subprogram_Parameters (Integer, Print_One);

26   package Print_2 is new Subprogram_Parameters (Integer, Print_One, Print_Two);

27   package Print_3 is new Subprogram_Parameters (Integer, Print_One, Print_Two, Print_Three_Prime);

28

29begin

30   Print_1.Print ("print_1", Global_Data.Value);

31   Global_Data.Add;

32   Print_2.Print ("print_2", Global_Data.Value);

33   Global_Data.Add;

34   Print_3.Print ("print_3", Global_Data.Value);

35end Test_Generic_Formal_Data;

generic_formal_data.adb

1package body Generic_Formal_Data is

2   package body Constants_And_Variables is

3      procedure Add is

4      begin

5         Variable := Variable + Increment;

6      end Add;

7   end Constants_And_Variables;

8

9   package body Subprogram_Parameters is

10      procedure Print (Prompt : String; Param : Type_T) is

11      begin

12         Print_One (Prompt, Param);

13         Print_Two (Prompt, Param);

14         Print_Three (Prompt, Param);

15      end Print;

16   end Subprogram_Parameters;

17end Generic_Formal_Data;

Footnotes

Inheritance

Primitives

primitives_example.ads

1package Primitives_Example is

2

3   type Record_T is record

4      Field : Integer;

5   end record;

6   type Access_To_Record_T is access Record_T;

7   type Array_T is array (1 .. 10) of Integer;

8

9   procedure Primitive_Of_Record_T (P : in out Record_T) is null;

10   function Primitive_Of_Record_T (P : Integer) return Record_T is

11     ((Field => P));

12   procedure Primitive_Of_Record_T (I : Integer;

13                                    P : access Record_T) is null;

14   procedure Not_A_Primitive_Of_Record_T

15     (I : Integer; P : Access_To_Record_T) is null;

16

17   procedure Primitive_Of_Record_T_And_Array_T

18     (P1 : in out Record_T; P2 : in out Array_T) is null;

19end Primitives_Example;

Simple Derivation

simple_derivation.ads

1package Simple_Derivation is

2   type Parent_T is range 1 .. 10;

3   function Primitive1 (V : Parent_T) return String is

4     ("Primitive1 of Parent_T" & V'Image);

5   function Primitive2 (V : Parent_T) return String is

6     ("Primitive2 of Parent_T" & V'Image);

7   function Primitive3 (V : Parent_T) return String is

8     ("Primitive3 of Parent_T" & V'Image);

9

10   type Child_T is new Parent_T; -- implicitly gets access to Primitive1

11

12   -- new behavior for Primitive2

13   overriding function Primitive2 (V : Child_T) return String is

14     ("Primitive2 of Child_T" & V'Image);

15

16   -- remove behavior for Primitive3 from Child_T

17   overriding function Primitive3 (V : Child_T) return String is abstract;

18

19   -- add primitive only for Child_T

20   not overriding function Primitive4 (V : Child_T) return String is

21     ("Primitive4 of Child_T" & V'Image);

22end Simple_Derivation;

test_simple_derivation.adb

1with Ada.Text_IO;       use Ada.Text_IO;

2with Simple_Derivation; use Simple_Derivation;

3procedure Test_Simple_Derivation is

4   function Not_A_Primitive (V : Parent_T) return String is

5     ("Not_A_Primitive" & V'Image);

6   Parent_V : Parent_T := 1;

7   Child_V  : Child_T  := 2;

8begin

9   Put_Line ("Parent_V - " & Primitive1 (Parent_V));

10   Put_Line ("Parent_V - " & Primitive2 (Parent_V));

11   Put_Line ("Parent_V - " & Primitive3 (Parent_V));

12   -- Put_Line ("Parent_V - " & Primitive4 (Parent_V)); -- illegal

13

14   Put_Line ("Child_V - " & Primitive1 (Child_V));

15   Put_Line ("Child_V - " & Primitive2 (Child_V));

16   -- Put_Line ("Child_V - " & Primitive3 (Child_V)); -- illegal

17   Put_Line ("Child_V - " & Primitive4 (Child_V));

18

19   Put_Line (Not_A_Primitive (Parent_V));

20   Put_Line (Not_A_Primitive (Parent_T (Child_V)));

21end Test_Simple_Derivation;

Tagged Derivation

tagged_derivation.ads

1package Tagged_Derivation is

2

3   type Root_T is tagged record

4      Root_Field : Integer;

5   end record;

6   function Primitive_1 (This : Root_T) return Integer is (This.Root_Field);

7   function Primitive_2 (This : Root_T) return String is

8     (Integer'Image (This.Root_Field));

9

10   type Child_T is new Root_T with record

11      Child_Field : Integer;

12   end record;

13   overriding function Primitive_2 (This : Child_T) return String is

14     (Integer'Image (This.Root_Field) & " " &

15      Integer'Image (This.Child_Field));

16   function Primitive_3 (This : Child_T) return Integer is

17     (This.Root_Field + This.Child_Field);

18

19   -- type Simple_Deriviation_T is new Child_T; -- illegal

20

21   type Root2_T is tagged record

22      Root_Field : Integer;

23   end record;

24   -- procedure Primitive_4 (X : Root_T; Y : Root2_T); -- illegal

25

26end Tagged_Derivation;

test_tagged_derivation.adb

1with Ada.Text_IO;       use Ada.Text_IO;

2with Tagged_Derivation; use Tagged_Derivation;

3procedure Test_Tagged_Derivation is

4   Root  : Root_T  := (Root_Field => 1);

5   Child : Child_T := (Root_Field => 11, Child_Field => 22);

6begin

7   Put_Line ("Root: " & Primitive_2 (Root));

8   Put_Line ("Child: " & Primitive_2 (Child));

9   Root := Root_T (Child);

10   Put_Line ("Root from Child: " & Primitive_2 (Root));

11   -- Child := Child_T ( Root ); -- illegal

12   -- Put_Line ( "Child from Root: " & Primitive_2 ( Child ) ); -- illegal

13   Child := (Root with Child_Field => 999);

14   Put_Line ("Child from Root via aggregate: " & Primitive_2 (Child));

15end Test_Tagged_Derivation;

Footnotes

Polymorphism

Classes Of Types

class_types.ads

1package Class_Types is

2   type Root_T is tagged null record;

3   type Child1_T is new Root_T with null record;

4   type Child2_T is new Root_T with null record;

5   type Grandchild1_T is new Child1_T with null record;

6

7   -- Root'Class = {Root_T, Child1_T, Child2_T, Grandchild1_T}

8   -- Child1'Class = {Child1_T, Grandchild1_T} Child2'Class = {Child2_T}

9   -- Granchild1'Class ={Grandchild1_T}

10   procedure Test;

11

12end Class_Types;

class_types.adb

1with Ada.Tags;    use Ada.Tags;

2with Ada.Text_IO; use Ada.Text_IO;

3package body Class_Types is

4   Root_Object  : Root_T;

5   Child_Object : Child1_T;

6

7   Class_Object1 : Child1_T'Class := Child_Object;

8   Class_Object2 : Root_T'Class   := Class_Object1;

9   Class_Object3 : Root_T'Class   := Child_Object;

10   -- Class_Object4 : Root_T'class; -- illegal

11

12   procedure Do_Something (Object : in out Root_T'Class) is

13   begin

14      Put_Line

15        ("Do_Something: " & Boolean'Image (Object in Root_T'Class) & " / " &

16         Boolean'Image (Object in Child1_T'Class));

17   end Do_Something;

18

19   procedure Test is

20   begin

21      Put_Line (Boolean'Image (Class_Object1'Tag = Class_Object2'Tag));

22      Put_Line (Boolean'Image (Class_Object2'Tag = Class_Object3'Tag));

23      Do_Something (Root_Object);

24      Do_Something (Child_Object);

25      Do_Something (Class_Object1);

26      Do_Something (Class_Object2);

27      Do_Something (Class_Object3);

28   end Test;

29end Class_Types;

abstract_types.ads

1package Abstract_Types is

2   type Root_T is abstract tagged record

3      Field : Integer;

4   end record;

5   function Primitive1 (V : Root_T) return String is abstract;

6   function Primitive2 (Prompt : String; V : Root_T) return String is

7      (Prompt & "> " & Integer'Image (V.Field));

8

9   type Child_T is abstract new Root_T with null record;

10   -- Child_T does not need to redefine any primitives

11

12   type Grandchild_T is new Child_T with null record;

13   -- Grandchild_T is required to create a concrete version of Primitive2

14   function Primitive1 (V : Grandchild_T) return String is

15     (Integer'Image (V.Field));

16

17   procedure Test;

18end Abstract_Types;

abstract_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Abstract_Types is

3   Object1 : constant Grandchild_T := (Field => 123);

4   Object2 : constant Root_T'Class := Object1;

5

6   procedure Test is

7   begin

8      Put_Line (Object1.Primitive1);

9      Put_Line (Primitive2 ("Object1", Object2));

10      Put_Line (Object2.Primitive1);

11      Put_Line (Primitive2 ("Object2", Object2));

12   end Test;

13

14end Abstract_Types;

test.adb

1with Abstract_Types;

2with Class_Types;

3procedure Test is

4begin

5   Class_Types.Test;

6   Abstract_Types.Test;

7end Test;

Dispatching And Redispatching

types.ads

1package Types is

2

3   type Root_T is tagged null record;

4   function Primitive (V : Root_T) return String is ("Root_T");

5

6   type Child_T is new Root_T with null record;

7   function Primitive (V : Child_T) return String is ("Child_T");

8

9end Types;

test_dispatching_and_redispatching.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Types;       use Types;

3procedure Test_Dispatching_And_Redispatching is

4

5   Root_Object  : Root_T;

6   Child_Object : Child_T;

7

8   V1 : constant Root_T'Class  := Root_Object;

9   V2 : constant Root_T'Class  := Child_Object;

10   V3 : constant Child_T'Class := Child_Object;

11

12begin

13

14   Put_Line (Primitive (V1));

15   Put_Line (Primitive (V2));

16   Put_Line (Primitive (V3));

17

18end Test_Dispatching_And_Redispatching;

Exotic Dispatching Operations

types.ads

1package Types is

2   type Root_T is tagged record

3      Field : Integer;

4   end record;

5   function Primitive (Left  : Root_T; Right : Root_T) return Integer is

6      (Left.Field + Right.Field);

7   function "=" (Left  : Root_T; Right : Root_T) return Boolean is

8      (Left.Field in Right.Field - 1 .. Right.Field + 1);

9   function Constructor (I : Integer := 0) return Root_T is ((Field => I));

10

11   type Child_T is new Root_T with null record;

12   overriding function Primitive (Left  : Child_T; Right : Child_T) return Integer is

13      (Left.Field * Right.Field);

14   overriding function "=" (Left  : Child_T; Right : Child_T) return Boolean is

15      (Right.Field in Left.Field - 1 .. Left.Field + 1);

16   -- function Constructor ( I : Integer := 0 ) return child_T; -- inherited from Root_t

17

18   type Child2_T is new Root_T with record

19      Field2 : Integer;

20   end record;

21   overriding function Primitive (Left  : Child2_T; Right : Child2_T) return Integer is

22      (Left.Field * Right.Field);

23   overriding function "=" (Left  : Child2_T; Right : Child2_T) return Boolean is

24      (Left.Field = Right.Field);

25   -- must create a constructor because new fields added

26   function Constructor (I : Integer := 0) return Child2_T is ((I, I));

27end Types;

test_exotic_dispatching_operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Types;       use Types;

3procedure Test_Exotic_Dispatching_Operations is

4   R1  : constant Root_T       := (Field => 10);

5   R2  : constant Root_T       := (Field => 20);

6   C1  : constant Child_T      := (Field => 10);

7   Cl1 : constant Root_T'Class := R1;

8   Cl2 : constant Root_T'Class := R2;

9   Cl3 : constant Root_T'Class := C1;

10

11   procedure Test_Primitive is

12   begin

13      Put_Line ("Primitive");

14      Put_Line (Integer'Image (Primitive (R1, R2)));                 -- static:  ok

15      -- Put_Line (Integer'Image (Primitive (R1, C1)));              -- static: error

16      Put_Line (Integer'Image (Primitive (Cl1, Cl2)));               -- dynamic: ok

17      -- Put_Line (Integer'Image (Primitive (R1, Cl1)));             -- static: error

18      Put_Line (Integer'Image (Primitive (Root_T'Class (R1), Cl1))); -- dynamic: ok

19      Put_Line (Integer'Image (Primitive (Cl1, Cl3)));               -- dynamic: error

20   end Test_Primitive;

21

22   procedure Test_Equality is

23   begin

24      Put_Line ("Equality");

25      Put_Line ("Cl1 = Cl2 " & Boolean'Image (Cl1 = Cl2));

26      Put_Line ("Cl2 = Cl3 " & Boolean'Image (Cl2 = Cl3));

27      Put_Line ("Cl3 = Cl1 " & Boolean'Image (Cl3 = Cl1));

28   end Test_Equality;

29

30   procedure Test_Constructor is

31      -- Static call to Root_T primitive

32      V1 : Root_T'Class := Root_T'(Constructor);

33      V2 : Root_T'Class := V1;

34      -- Static call to Child2_T primitive

35      V3 : Root_T'Class := Child2_T'(Constructor);

36      -- V4 : Root_T'Class := Constructor; -- What is the tag of V4?

37   begin

38      -- No

39      -- V1 := Constructor;

40

41      -- Yes

42      V1 := Root_T'(Constructor);

43   end Test_Constructor;

44

45begin

46   Test_Equality;

47   Test_Constructor;

48   Test_Primitive;

49end Test_Exotic_Dispatching_Operations;

Footnotes

Exceptions

Handlers

joy_ride.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Automotive;  use Automotive;

3procedure Joy_Ride is

4   Hot_Rod : Vehicle_T;

5   Bored   : Boolean := False;

6begin

7   while not Bored loop

8      Steer_Aimlessly (Bored);

9      Consume_Fuel (Hot_Rod);

10   end loop;

11   Put_Line ("Driving Home");

12   Drive_Home;

13exception

14   when Fuel_Exhausted =>

15      Put_Line ("Pushing Home");

16      Push_Home;

17end Joy_Ride;

automotive.ads

1package Automotive is

2   Fuel_Exhausted : exception;

3

4   type Vehicle_T is record

5      Fuel_Quantity : Float := 10.0;

6      Fuel_Minimum  : Float := 1.0;

7   end record;

8

9   procedure Consume_Fuel (Car : in out Vehicle_T);

10   procedure Steer_Aimlessly (Flag : out Boolean);

11   procedure Drive_Home;

12   procedure Push_Home;

13end Automotive;

automotive.adb

1with GNAT.Random_Numbers; use GNAT.Random_Numbers;

2package body Automotive is

3   Gen : Generator;

4   function Current_Consumption is new Random_Float (Float);

5   function Random_Number is new Random_Discrete (Integer);

6

7   procedure Consume_Fuel (Car : in out Vehicle_T) is

8   begin

9      if Car.Fuel_Quantity <= Car.Fuel_Minimum then

10         raise Fuel_Exhausted;

11      else

12         Car.Fuel_Quantity := Car.Fuel_Quantity - Current_Consumption (Gen);

13      end if;

14   end Consume_Fuel;

15

16   procedure Steer_Aimlessly (Flag : out Boolean) is

17   begin

18      Flag := Random_Number (Gen, 1, 50) = 1;

19      if Random_Number (Gen, 1, 50) = 2 then

20         raise Constraint_Error;

21      end if;

22   end Steer_Aimlessly;

23

24   procedure Drive_Home is null;

25   procedure Push_Home is null;

26

27begin

28   Reset (Gen);

29end Automotive;

Implicitly And Explicitly Raised Exceptions

implicit_exceptions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Implicit_Exceptions is

3   Array_Object : array (1 .. 100) of Integer;

4

5   procedure Raise_Constraint_Error (X : Integer) is

6   begin

7      Put_Line ("* Raise_Constraint_Error: " & X'Image);

8      Array_Object (X) := X - 10;

9   end Raise_Constraint_Error;

10

11   function Raise_Program_Error (X : Integer) return Boolean is

12   begin

13      Put_Line ("* Raise_Program_Error: " & X'Image);

14      if X in Array_Object'Range then

15         return Array_Object (X) > 0;

16      end if;

17   end Raise_Program_Error;

18end Implicit_Exceptions;

explicit_exceptions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Explicit_Exceptions is

3   procedure Raise_Storage_Error (X : Integer) is

4   begin

5      Put_Line ("* Raise_Storage_Error: " & X'Image);

6      if X < 0 then

7         raise Storage_Error;

8      end if;

9   end Raise_Storage_Error;

10end Explicit_Exceptions;

test_exceptions.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2with Implicit_Exceptions; use Implicit_Exceptions;

3with Explicit_Exceptions; use Explicit_Exceptions;

4procedure Test_Exceptions is

5   procedure Test_Constraint_Error (X : Integer) is

6   begin

7      Raise_Constraint_Error (X);

8      Put_Line ("Test_Constraint_Error success");

9   exception

10      when Constraint_Error =>

11         Put_Line ("Test_Constraint_Error caught exception");

12   end Test_Constraint_Error;

13

14   procedure Test_Program_Error (X : Integer) is

15   begin

16      if Raise_Program_Error (X) then

17         Put_Line ("Test_Program_Error true");

18      else

19         Put_Line ("Test_Program_Error false");

20      end if;

21   exception

22      when Program_Error =>

23         Put_Line ("Test_Program_Error caught exception");

24   end Test_Program_Error;

25

26   procedure Test_Storage_Error (X : Integer) is

27   begin

28      Raise_Storage_Error (X);

29      Put_Line ("Test_Storage_Error success");

30   exception

31      when Storage_Error =>

32         Put_Line ("Test_Storage_Error caught exception");

33   end Test_Storage_Error;

34

35begin

36   Test_Constraint_Error (20);

37   Test_Constraint_Error (0);

38   Test_Constraint_Error (Integer'Last);

39   Test_Program_Error (Integer'First);

40   Test_Program_Error (Integer'Last);

41   Test_Storage_Error (Integer'First);

42   Test_Storage_Error (Integer'Last);

43end Test_Exceptions;

implicit_exceptions.ads

1package Implicit_Exceptions is

2   procedure Raise_Constraint_Error (X : Integer);

3   function Raise_Program_Error (X : Integer) return Boolean;

4end Implicit_Exceptions;

explicit_exceptions.ads

1package Explicit_Exceptions is

2   procedure Raise_Storage_Error (X : Integer);

3end Explicit_Exceptions;

User Defined Exceptions

stack.ads

1package Stack is

2   Underflow, Overflow : exception;

3   procedure Push (Item : in Integer);

4   procedure Pop (Item : out Integer);

5end Stack;

stack.adb

1package body Stack is

2   Values : array (1 .. 100) of Integer;

3   Top    : Integer := 0;

4

5   procedure Push (Item : in Integer) is

6   begin

7      if Top = Values'Last then

8         raise Overflow;

9      end if;

10      Top          := Top + 1;

11      Values (Top) := Item;

12   end Push;

13

14   procedure Pop (Item : out Integer) is

15   begin

16      if Top < Values'First then

17         raise Underflow;

18      end if;

19      Item := Values (Top);

20      Top  := Top - 1;

21   end Pop;

22end Stack;

test_stack.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Stack;

3procedure Test_Stack is

4   Global : Integer := 123;

5

6   procedure Push (X : Integer) is

7   begin

8      Stack.Push (X);

9   exception

10      when Stack.Overflow =>

11         Put_Line ("No room on the stack");

12   end Push;

13

14   procedure Pop is

15   begin

16      Stack.Pop (Global);

17   exception

18      when Stack.Underflow =>

19         Put_Line ("Nothing on the stack");

20   end Pop;

21

22begin

23   Pop;

24   for I in 1 .. 100 loop

25      Push (I);

26   end loop;

27   Push (2);

28end Test_Stack;

Propagation

propagation.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2with GNAT.Random_Numbers; use GNAT.Random_Numbers;

3procedure Propagation is

4   Error1 : exception;

5   Error2 : exception;

6

7   Gen : Generator;

8   procedure Maybe_Raise is

9      Test : constant Float := Random (Gen);

10   begin

11      if Test > 0.666 then

12         raise Error1;

13      end if;

14   exception

15      when Error1 =>

16         if Test > 0.95 then

17            raise Error2;

18         else

19            raise;

20         end if;

21   end Maybe_Raise;

22

23   procedure One is

24   begin

25      Maybe_Raise;

26   end One;

27

28   procedure Two is

29   begin

30      One;

31      Maybe_Raise;

32   exception

33      when Error1 =>

34         Put_Line ("Exception from 1 or 2");

35   end Two;

36

37begin

38   Reset (Gen);

39   Maybe_Raise;

40   Two;

41exception

42   when Error1 =>

43      Put_Line ("Exception from 3");

44end Propagation;

Exceptions As Objects

exception_objects_example.ads

1package Exception_Objects_Example is

2

3   Public_Exception : exception;

4

5   procedure Do_Something (X : Integer);

6

7end Exception_Objects_Example;

exception_objects_example.adb

1package body Exception_Objects_Example is

2   Hidden_Exception : exception;

3

4   procedure Do_Something (X : Integer) is

5   begin

6      if X < 0 then

7         raise Public_Exception;

8      elsif X = 0 then

9         raise Hidden_Exception;

10      end if;

11   end Do_Something;

12

13end Exception_Objects_Example;

test_exception_objects_example.adb

1with Ada.Exceptions;            use Ada.Exceptions;

2with Ada.Text_IO;               use Ada.Text_IO;

3with Exception_Objects_Example; use Exception_Objects_Example;

4procedure Test_Exception_Objects_Example is

5begin

6

7   for I in -1 .. 1 loop

8      begin

9         Put_Line ("Try " & I'Image);

10         Do_Something (I);

11         Put_Line ("   success");

12      exception

13         when Public_Exception =>

14            Put_Line ("   Expected exception");

15         when The_Err : others =>

16            Put_Line ("   Unexpected exception");

17            Put_Line ("      Name: " & Exception_Name (The_Err));

18            Put_Line ("      Information: " & Exception_Information (The_Err));

19            Put_Line ("      Message: " & Exception_Message (The_Err));

20      end;

21   end loop;

22

23end Test_Exception_Objects_Example;

Footnotes

Elaboration

Elaboration

elab_1.ads

1with Initializer; use Initializer;

2package Elab_1 is

3   Spec_Object : Integer := Call (101);

4   procedure Proc;

5end Elab_1;

elab_1.adb

1package body Elab_1 is

2   Body_Object : Integer := Call (102);

3   procedure Proc is null;

4begin

5   Body_Object := Body_Object + Call (103);

6end Elab_1;

elab_2.ads

1with Initializer; use Initializer;

2package Elab_2 is

3   Spec_Object : Integer := Call (201);

4   procedure Proc;

5end Elab_2;

elab_2.adb

1package body Elab_2 is

2   Body_Object : Integer := Call (202);

3   procedure Proc is null;

4begin

5   Body_Object := Body_Object + Call (203);

6end Elab_2;

test_elab.adb

1with Elab_2;

2with Elab_1;

3procedure Test_Elab is

4begin

5   Elab_2.Proc;

6   Elab_1.Proc;

7end Test_Elab;

initializer.ads

1package Initializer is

2   function Call (I : Integer) return Integer;

3end Initializer;

initializer.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Initializer is

3   function Call (I : Integer) return Integer is

4   begin

5      Put_Line ("Call with " & Integer'Image (I));

6      return I;

7   end Call;

8end Initializer;

Elaboration Control

pure_p.ads

1package Pure_P is

2   pragma Pure;

3   Some_Constant : constant Integer := Integer'Size;

4   function Call (I : Integer) return Integer is (I);

5end Pure_P;

preelaborate_p.ads

1with Pure_P;

2package Preelaborate_P is

3   pragma Preelaborate;

4   Global_Object : Integer := Pure_P.Some_Constant;

5end Preelaborate_P;

elaborate_body_p.ads

1package Elaborate_Body_P is

2   pragma Elaborate_Body;

3   function Call (I : Integer) return Integer;

4end Elaborate_Body_P;

elaborate_body_p.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Elaborate_Body_P is

3   function Call (I : Integer) return Integer is

4   begin

5      Put_Line ("Call with " & Integer'Image (I));

6      return I;

7   end Call;

8begin

9   Put_Line ("Elaborate_Body_P package execution");

10end Elaborate_Body_P;

elab_1.ads

1with Elaborate_Body_P; use Elaborate_Body_P;

2pragma Elaborate (Elaborate_Body_P);

3package Elab_1 is

4   Spec_Object : Integer := Call (101);

5   procedure Proc;

6end Elab_1;

elab_1.adb

1with Elab_2;

2package body Elab_1 is

3   Body_Object : Integer := Call (102);

4   procedure Proc is null;

5begin

6   Body_Object := Body_Object + Call (103);

7   Elab_2.Proc;

8end Elab_1;

elab_2.ads

1with Elaborate_Body_P; use Elaborate_Body_P;

2package Elab_2 is

3   Spec_Object : Integer := Call (201);

4   procedure Proc;

5end Elab_2;

elab_2.adb

1package body Elab_2 is

2   Body_Object : Integer := Call (202);

3   procedure Proc is null;

4begin

5   Body_Object := Body_Object + Call (203);

6end Elab_2;

test_elab_control.adb

1with Elab_2;

2with Elab_1;

3pragma Elaborate_All (Elab_2);

4procedure Test_Elab_Control is

5begin

6   Elab_1.Proc;

7   Elab_2.Proc;

8end Test_Elab_Control;

Footnotes

Subprogram Contracts

Preconditions And Postconditions

stack_pkg.ads

1package Stack_Pkg is

2   procedure Push (Item : in Integer) with

3         Pre  => not Full,

4         Post => not Empty and then Top = Item;

5   procedure Pop (Item : out Integer) with

6         Pre  => not Empty,

7         Post => not Full and Item = Top'Old;

8   function Pop return Integer with

9         Pre  => not Empty,

10         Post => not Full and Pop'Result = Top'Old;

11   function Top return Integer with

12         Pre => not Empty;

13   function Empty return Boolean;

14   function Full return Boolean;

15end Stack_Pkg;

stack_pkg.adb

1package body Stack_Pkg is

2   Values  : array (1 .. 100) of Integer;

3   Current : Natural := 0;

4

5   -- Push/Pop cannot fail because preconditions prevent it

6   procedure Push (Item : in Integer) is

7   begin

8      Current          := Current + 1;

9      Values (Current) := Item;

10   end Push;

11

12   procedure Pop (Item : out Integer) is

13   begin

14      Item    := Values (Current);

15      Current := Current - 1;

16   end Pop;

17

18   function Pop return Integer is

19      Item : constant Integer := Values (Current);

20   begin

21      Current := Current - 1;

22      return Item;

23   end Pop;

24

25   function Top return Integer is (Values (Current));

26   function Empty return Boolean is (Current not in Values'Range);

27   function Full return Boolean is (Current >= Values'Length);

28end Stack_Pkg;

Footnotes

Type Contracts

Type Invariants

bank.ads

1package Bank is

2   type Account_T is private with Type_Invariant => Consistent_Balance (Account_T);

3   type Currency_T is delta 0.01 digits 12;

4   function Consistent_Balance (This : Account_T) return Boolean;

5   procedure Open (This : in out Account_T; Initial_Deposit : Currency_T);

6private

7   type List_T is array (1 .. 100) of Currency_T;

8   type Transaction_List_T is record

9      Values : List_T;

10      Count  : Natural := 0;

11   end record;

12   type Account_T is record -- initial state MUST satisfy invariant

13      Current_Balance : Currency_T := 0.0;

14      Withdrawals     : Transaction_List_T;

15      Deposits        : Transaction_List_T;

16   end record;

17end Bank;

bank.adb

1package body Bank is

2   function Total (This : Transaction_List_T) return Currency_T is

3      Result : Currency_T := 0.0;

4   begin

5      for I in 1 .. This.Count loop -- no iteration if list empty

6         Result := Result + This.Values (I);

7      end loop;

8      return Result;

9   end Total;

10   function Consistent_Balance (This : Account_T) return Boolean is

11      ( Total (This.Deposits) - Total (This.Withdrawals) = This.Current_Balance );

12   procedure Open (This : in out Account_T; Initial_Deposit : Currency_T) is

13   begin

14      This.Current_Balance := Initial_Deposit;

15      -- if we checked, the invariant would be false here!

16      This.Withdrawals.Count   := 0;

17      This.Deposits.Count      := 1;

18      This.Deposits.Values (1) := Initial_Deposit;

19   end Open; -- invariant is now true

20end Bank;

Subtype Predicates

predicates.adb

1with Ada.Exceptions; use Ada.Exceptions;

2with Ada.Text_IO;    use Ada.Text_IO;

3procedure Predicates is

4

5   subtype Even_T is Integer with Dynamic_Predicate => Even_T mod 2 = 0;

6   type Serial_Baud_Rate_T is range 110 .. 115_200 with

7      Static_Predicate => Serial_Baud_Rate_T in -- Non-contiguous range

8          2_400 | 4_800 | 9_600 | 14_400 | 19_200 | 28_800 | 38_400 | 56_000;

9

10   -- This must be dynamic because "others" will be evaluated at run-time

11   subtype Vowel_T is Character with Dynamic_Predicate =>

12         (case Vowel_T is when 'A' | 'E' | 'I' | 'O' | 'U' => True, when others => False);

13

14   type Table_T is array (Integer range <>) of Integer;

15   subtype Sorted_Table_T is Table_T (1 .. 5) with

16        Dynamic_Predicate =>

17        (for all K in Sorted_Table_T'Range =>

18           (K = Sorted_Table_T'First or else Sorted_Table_T (K - 1) <= Sorted_Table_T (K)));

19

20   J      : Even_T;

21   Values : Sorted_Table_T := (1, 3, 5, 7, 9);

22

23begin

24   begin

25      Put_Line ("J is" & J'Img);

26      J := Integer'Succ (J); -- assertion failure here

27      Put_Line ("J is" & J'Img);

28      J := Integer'Succ (J); -- or maybe here

29      Put_Line ("J is" & J'Img);

30   exception

31      when The_Err : others =>

32         Put_Line (Exception_Message (The_Err));

33   end;

34

35   for Baud in Serial_Baud_Rate_T loop

36      Put_Line (Baud'Image);

37   end loop;

38

39   Put_Line (Vowel_T'Image (Vowel_T'Succ ('A')));

40   Put_Line (Vowel_T'Image (Vowel_T'Pred ('Z')));

41

42   begin

43      Values (3) := 0; -- not an exception

44      Values     := (1, 3, 0, 7, 9); -- exception

45   exception

46      when The_Err : others =>

47         Put_Line (Exception_Message (The_Err));

48   end;

49end Predicates;

Footnotes

Low Level Programming

Data Representation

test_data_representation.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Test_Data_Representation is

3

4   type Enum is (E1, E2, E3);

5

6   procedure Attributes is

7      type Integer_T is range 1 .. 10;

8      type Similar_Integer_T is range 1 .. 10 with

9         Size        => 13,

10         Object_Size => 16,

11         Alignment   => 1;

12   begin

13      Put_Line

14        ("Integer_T 'Size / 'Object_size / 'Alignment " &

15         Integer'Image (Integer_T'Size) &

16         Integer'Image (Integer_T'Object_Size) &

17         Integer'Image (Integer_T'Alignment));

18      Put_Line

19        ("Similar_Integer_T 'Size / 'Object_size / 'Alignment " &

20         Integer'Image (Similar_Integer_T'Size) &

21         Integer'Image (Similar_Integer_T'Object_Size) &

22         Integer'Image (Similar_Integer_T'Alignment));

23   end Attributes;

24

25   procedure Representation_Clauses is

26

27      type Normal_Record_T is record

28         A : Integer range 0 .. 4;

29         B : Boolean;

30         C : Integer;

31         D : Enum := E1;

32      end record;

33      type Normal_Array_T is array (1 .. 1_000) of Boolean;

34

35      type Packed_Record_T is record

36         A : Integer range 0 .. 4;

37         B : Boolean;

38         C : Integer;

39         D : Enum := E2;

40      end record with

41         Pack;

42      type Packed_Array_T is array (1 .. 1_000) of Boolean with

43         Pack;

44

45      type Repped_Record_T is record

46         A : Integer range 0 .. 4;

47         B : Boolean;

48         C : Integer;

49         D : Enum := E3;

50      end record;

51      for Repped_Record_T use record

52         A at 0 range 0 ..  2;

53         B at 0 range 3 ..  3;

54         C at 0 range 5 .. 36;

55         D at 5 range 0 ..  2;

56      end record;

57      type Repped_Array_T is array (1 .. 1_000) of Boolean;

58      for Repped_Array_T'Component_Size use 2;

59

60   begin

61      Put_Line

62        ("Size of normal record / array: " &

63         Integer'Image (Normal_Record_T'Size) &

64         Integer'Image (Normal_Array_T'Size));

65      Put_Line

66        ("Size of packed record / array: " &

67         Integer'Image (Packed_Record_T'Size) &

68         Integer'Image (Packed_Array_T'Size));

69      Put_Line

70        ("Size of repped record / array: " &

71         Integer'Image (Repped_Record_T'Size) &

72         Integer'Image (Repped_Array_T'Size));

73   end Representation_Clauses;

74

75begin

76   Attributes;

77   Representation_Clauses;

78

79end Test_Data_Representation;

Address Clauses And Overlays

test_address_clauses_and_overlays.adb

1with Ada.Text_IO;             use Ada.Text_IO;

2with System;

3with System.Storage_Elements; use System.Storage_Elements;

4procedure Test_Address_Clauses_And_Overlays is

5

6   type Bitfield_T is array (Integer range <>) of Boolean with

7      Pack;

8

9   V : aliased Integer; -- object can be referenced elsewhere

10   pragma Volatile (V);  -- may be updated at any time

11

12   V2 : aliased Integer;

13   pragma Volatile (V2);

14

15   V_A : constant System.Address  := V'Address;

16   V_I : constant Integer_Address := To_Integer (V_A);

17

18   --  This maps directly on to the bits of V

19   V3 : aliased Bitfield_T (1 .. V'Size);

20   for V3'Address use V_A; -- overlays V

21

22   V4 : aliased Integer;

23   --  Trust me, I know what I'm doing, this is V2

24   for V4'Address use To_Address (V_I - 4);

25

26   function Str (Bitfield : Bitfield_T) return String is

27      Retval : String (Bitfield'First .. Bitfield'Last);

28   begin

29      for I in Bitfield'Range loop

30         Retval (I) := (if Bitfield (I) then '1' else '0');

31      end loop;

32      return Retval;

33   end Str;

34

35begin

36

37   V := 123;

38   Put (Integer'Image (V) & " => " & Str (V3));

39   New_Line;

40

41   V3 (V3'First + 2) := not V3 (V3'First + 2);

42   Put (Str (V3) & " => " & Integer'Image (V));

43   New_Line;

44

45   V2 := 456;

46   Put_Line ("V4 = " & Integer'Image (V4));

47   V4 := 789;

48   Put_Line ("V2 = " & Integer'Image (V2));

49

50end Test_Address_Clauses_And_Overlays;

Footnotes

Tasking

Tasks

tasks.ads

1package Tasks is

2   task T is

3      entry Start;

4      entry Receive_Message (V : String);

5   end T;

6end Tasks;

tasks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Tasks is

3   task body T is

4   begin

5      loop

6         accept Start do

7            Put_Line ("Start");

8         end Start;

9         accept Receive_Message (V : String) do

10            Put_Line ("Receive " & V);

11         end Receive_Message;

12      end loop;

13   end T;

14end Tasks;

test_tasks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Tasks;       use Tasks;

3procedure Test_Tasks is

4begin

5   Put_Line ("calling start");

6   T.Start;

7   Put_Line ("calling receive 1");

8   T.Receive_Message ("1");

9   Put_Line ("calling receive 2");

10   --  Locks until somebody calls Start

11   T.Receive_Message ("2");

12end Test_Tasks;

Protected Objects

protected_objects.ads

1package Protected_Objects is

2   protected Object is

3      procedure Set (Prompt : String; V : Integer);

4      function Get (Prompt : String) return Integer;

5   private

6      Local : Integer := 0;

7   end Object;

8end Protected_Objects;

protected_objects.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Protected_Objects is

3   protected body Object is

4      procedure Set (Prompt : String; V : Integer) is

5         Str : constant String := "Set " & Prompt & V'Image;

6      begin

7         Local := V;

8         Put_Line (Str);

9      end Set;

10      function Get (Prompt : String) return Integer is

11         Str : constant String := "Get " & Prompt & Local'Image;

12      begin

13         Put_Line (Str);

14         return Local;

15      end Get;

16   end Object;

17end Protected_Objects;

tasks.ads

1package Tasks is

2   task T1 is

3      entry Start;

4      entry Receive_Message;

5   end T1;

6   task T2 is

7      entry Start;

8      entry Receive_Message;

9   end T2;

10end Tasks;

test_protected_objects.adb

1with Tasks; use Tasks;

2procedure Test_Protected_Objects is

3begin

4   T1.Start;

5   T1.Receive_Message;

6   T2.Start;

7   T2.Receive_Message;

8   T2.Receive_Message;

9   T1.Receive_Message;

10end Test_Protected_Objects;

tasks.adb

1with Protected_Objects; use Protected_Objects;

2package body Tasks is

3   task body T1 is

4   begin

5      accept Start do

6         Object.Set ("T1 Start", 0);

7      end Start;

8      loop

9         accept Receive_Message do

10            Object.Set ("T1 Receive", Object.Get ("T1 Receive") + 1);

11         end Receive_Message;

12      end loop;

13   end T1;

14

15   task body T2 is

16   begin

17      accept Start do

18         Object.Set ("T2 Start", 0);

19      end Start;

20      loop

21         accept Receive_Message do

22            Object.Set ("T2 Receive", Object.Get ("T2 Receive") + 1);

23         end Receive_Message;

24      end loop;

25   end T2;

26end Tasks;

Task And Protected Types

tasks.ads

1package Tasks is

2   task type T is

3      entry Start (Id : Character; Initial_1, Initial_2 : Integer);

4      entry Receive_Message (Delta_1, Delta_2 : Integer);

5   end T;

6   T1, T2 : T;

7end Tasks;

protected_objects.ads

1package Protected_Objects is

2   protected type Object is

3      procedure Set (Caller : Character; V : Integer);

4      function Get return Integer;

5      procedure Initialize (My_Id : Character);

6   private

7      Local : Integer   := 0;

8      Id    : Character := ' ';

9   end Object;

10   O1, O2 : Object;

11end Protected_Objects;

test_types.adb

1with Tasks;             use Tasks;

2with Protected_Objects; use Protected_Objects;

3procedure Test_Types is

4begin

5   O1.Initialize ('X');

6   O2.Initialize ('Y');

7   T1.Start ('A', 1, 2);

8   T2.Start ('B', 1_000, 2_000);

9   T1.Receive_Message (1, 2);

10   T2.Receive_Message (10, 20);

11end Test_Types;

tasks.adb

1with Protected_Objects; use Protected_Objects;

2package body Tasks is

3   task body T is

4      My_Id : Character := ' ';

5   begin

6      accept Start (Id : Character; Initial_1, Initial_2 : Integer) do

7         My_Id := Id;

8         O1.Set (My_Id, Initial_1);

9         O2.Set (My_Id, Initial_2);

10      end Start;

11      loop

12         accept Receive_Message (Delta_1, Delta_2 : Integer) do

13            declare

14               New_1 : constant Integer := O1.Get + Delta_1;

15               New_2 : constant Integer := O2.Get + Delta_2;

16            begin

17               O1.Set (My_Id, New_1);

18               O2.Set (My_Id, New_2);

19            end;

20         end Receive_Message;

21      end loop;

22   end T;

23end Tasks;

protected_objects.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Protected_Objects is

3   protected body Object is

4      procedure Initialize (My_Id : Character) is

5      begin

6         Id := My_Id;

7      end Initialize;

8      procedure Set (Caller : Character; V : Integer) is

9      begin

10         Local := V;

11         Put_Line ( "Task-" & Caller & " Object-" & Id & " => " & V'Image );

12      end Set;

13      function Get return Integer is

14      begin

15         return Local;

16      end Get;

17   end Object;

18end Protected_Objects;

Some Advanced Concepts

some_advanced_concepts.ads

1package Some_Advanced_Concepts is

2   Termination_Flag : Boolean := False;

3   task Select_Loop_Task is

4      entry Start;

5      entry Receive_Message (V : String);

6      entry Send_Message (V : String);

7      entry Stop;

8   end Select_Loop_Task;

9end Some_Advanced_Concepts;

some_advanced_concepts.adb

1with Ada.Calendar; use Ada.Calendar;

2with Ada.Text_IO;  use Ada.Text_IO;

3package body Some_Advanced_Concepts is

4   task body Select_Loop_Task is

5   begin

6      accept Start do

7         Put_Line ("Select_Loop_Task started at" &

8                   Day_Duration'Image (Seconds (Clock)));

9      end Start;

10      loop

11         select

12            accept Receive_Message (V : String) do

13               Put_Line ("Select_Loop_Task Receive: " & V);

14            end Receive_Message;

15         or

16            accept Send_Message (V : String) do

17               Put_Line ("Select_Loop_Task Send: " & V);

18            end Send_Message;

19         or when Termination_Flag =>

20            accept Stop;

21         or

22            delay 5.0;

23            Put_Line ("No more waiting at" & Day_Duration'Image (Seconds (Clock)));

24            exit;

25         end select;

26      end loop;

27   end Select_Loop_Task;

28

29end Some_Advanced_Concepts;

test_some_advanced_concepts.adb

1with Ada.Text_IO;            use Ada.Text_IO;

2with Some_Advanced_Concepts; use Some_Advanced_Concepts;

3procedure Test_Some_Advanced_Concepts is

4begin

5   Put_Line ("calling start");

6   Select_Loop_Task.Start;

7   Select_Loop_Task.Receive_Message ("1");

8   Select_Loop_Task.Send_Message ("A");

9   Select_Loop_Task.Send_Message ("B");

10   Select_Loop_Task.Receive_Message ("2");

11   Select_Loop_Task.Stop;

12exception

13   when Tasking_Error =>

14      Put_Line ("Expected exception: Entry not reached");

15end Test_Some_Advanced_Concepts;

Footnotes

Contents:

- Declarations

- Identifiers Comments And Pragmas

- Numeric Literals

- Object Declarations

- Named Numbers

- Scope And Visibility

- Aspect Clauses

- Basic Types

- Discrete Numeric Types

- Discrete Enumeration Types

- Real Types

- Statements

- Assignment Statements

- Conditional Statements

- Loop Statements

- Array Types

- Constrained Array Types

- Unconstrained Array Types

- Attributes

- Operations

- Operations Added For Ada2012

- Aggregates

- Record Types

- Components Rules

- Operations

- Aggregates

- Default Values

- Variant Records

- Subprograms

- Declarations And Bodies

- Parameters

- Expression Functions

- Potential Pitfalls

- Expressions

- Subtypes

- Membership Tests

- Slices

- Conditional Expressions

- Quantified Expressions

- Overloading

- Enumerals And Operators

- Call Resolution

- Visibility Issues

- User Defined Equality

- Composition Of Equality

- Library Units

- Library Units

- With Clauses

- Packages

- Declarations

- Bodies

- Executable Parts

- Idioms

- Private Types

- Implementing Abstract Data Types Via Views

- Private Part Construction

- Idioms

- Limited Types

- Declarations

- Creating Values

- Extended Return Statements

- Combining Limited And Private Views

- Program Structure

- Limited With Clauses

- Hierarchical Library Units

- Visibility Limits

- Private Children

- Visibility

- Use Clauses

- Use Type Clauses

- Use All Type Clauses

- Access Types

- Pool Specific Access Types

- General Access Types

- Access Types

- Accessibility Checks

- Memory Management

- Anonymous Access Types

- Genericity

- Generic Data

- Generic Formal Data

- Inheritance

- Primitives

- Simple Derivation

- Tagged Derivation

- Polymorphism

- Classes Of Types

- Dispatching And Redispatching

- Exotic Dispatching Operations

- Exceptions

- Handlers

- Implicitly And Explicitly Raised Exceptions

- User Defined Exceptions

- Propagation

- Exceptions As Objects

- Elaboration

- Elaboration

- Elaboration Control

- Subprogram Contracts

- Preconditions And Postconditions

- Type Contracts

- Type Invariants

- Subtype Predicates

- Low Level Programming

- Data Representation

- Address Clauses And Overlays

- Tasking

- Tasks

- Protected Objects

- Task And Protected Types

- Some Advanced Concepts

Footnotes

aspect_clauses.ads

1package Aspect_Clauses is

2   Eight_Bits : Integer range 0 .. 255 with

3      Size => 8;

4   Object : Integer with

5      Atomic;

6end Aspect_Clauses;

Footnotes

identifiers_comments_and_pragmas.ads

1package Identifiers_Comments_And_Pragmas is

2

3   Spaceperson : Integer;

4   --SPACEPERSON : integer; -- identifier is a duplicate

5   Space_Person : Integer;

6   --Null : integer := 0; -- identifier is a reserved word

7   pragma Unreferenced (Spaceperson);

8   pragma Unreferenced (Space_Person);

9

10end Identifiers_Comments_And_Pragmas;

Footnotes

named_numbers.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Named_Numbers is

3   Universal_Third       : constant       := 1.0 / 3.0;

4   Float_Third           : constant Float := 1.0 / 3.0;

5   Float_Value           : Float;

6   Long_Float_Value      : Long_Float;

7   Long_Long_Float_Value : Long_Long_Float;

8begin

9   Float_Value           := Universal_Third;

10   Long_Float_Value      := Universal_Third;

11   Long_Long_Float_Value := Universal_Third;

12   Put_Line (Float'Image (Float_Value));

13   Put_Line (Long_Float'Image (Long_Float_Value));

14   Put_Line (Long_Long_Float'Image (Long_Long_Float_Value));

15   Float_Value           := Float_Third;

16   Long_Float_Value      := Long_Float (Float_Third);

17   Long_Long_Float_Value := Long_Long_Float (Float_Third);

18   Put_Line (Float'Image (Float_Value));

19   Put_Line (Long_Float'Image (Long_Float_Value));

20   Put_Line (Long_Long_Float'Image (Long_Long_Float_Value));

21end Named_Numbers;

Footnotes

numeric_literals.ads

1package Numeric_Literals is

2

3   Simple_Integer  : constant := 3;

4   Decimal_Number  : constant := 0.25;

5   Using_Separator : constant := 1_000_000.0;

6   Octal           : constant := 8#33#;

7   Hexadecimal     : constant := 16#AAAA#;

8

9end Numeric_Literals;

Footnotes

object_declarations.ads

1with Ada.Calendar; use Ada.Calendar;

2package Object_Declarations is

3   A    : Integer := 0;

4   B, C : Time    := Clock;

5   D    : Integer := A + 1;

6end Object_Declarations;

Footnotes

scope_and_visibility.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Scope_And_Visibility is

3   Name : Integer;

4begin

5   Name := 1;

6   declare

7      Name : Float := 2.0;

8   begin

9      Name := Name + Float (Scope_And_Visibility.Name);

10      Put_Line (Name'Image);

11   end;

12   Put_Line (Name'Image);

13end Scope_And_Visibility;

Footnotes

discrete_enumeration_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Discrete_Enumeration_Types is

3

4   type Colors_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);

5   Color : Colors_Type := Red;

6

7   type Traffic_Light_Type is (Red, Yellow, Green);

8   for Traffic_Light_Type use (1, 2, 4);

9   Stoplight : Traffic_Light_Type := Red;

10

11   type Roman_Numeral_Digit_Type is ('I', 'V', 'X', 'L', 'C', 'M');

12   Digit : Roman_Numeral_Digit_Type := 'I';

13

14   Flag : Boolean;

15

16   Position : Integer;

17

18begin

19

20   Position  := Traffic_Light_Type'Pos (Green);

21   Color     := Colors_Type'Val (Position);

22   Stoplight := Traffic_Light_Type'(Red);

23   Digit     := Roman_Numeral_Digit_Type'Succ (Digit);

24   Flag      := End_Of_Line;

25

26   Put_Line (Position'Image);

27   Put_Line (Color'Image);

28   Put_Line (Flag'Image);

29   Put_Line (Digit'Image);

30   Put_Line (Stoplight'Image);

31

32end Discrete_Enumeration_Types;

Footnotes

discrete_numeric_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Discrete_Numeric_Types is

3

4   type Signed_Integer_Type is range -128 .. 127;

5   Signed_Integer : Signed_Integer_Type := 100;

6

7   type Unsigned_Integer_Type is mod 256;

8   Unsigned_Integer : Unsigned_Integer_Type := 100;

9

10begin

11

12   Signed_Integer := Signed_Integer_Type'Last;

13   Signed_Integer := Signed_Integer_Type'Succ (Signed_Integer);

14   Put_Line (Signed_Integer'Image);

15

16   Unsigned_Integer := Unsigned_Integer_Type'First;

17   Unsigned_Integer := Unsigned_Integer_Type'Pred (Unsigned_Integer);

18   Put_Line (Unsigned_Integer'Image);

19

20   Unsigned_Integer := Unsigned_Integer_Type (Signed_Integer);

21   Put_Line (Unsigned_Integer'Image);

22

23   Unsigned_Integer := Unsigned_Integer_Type'Mod (Signed_Integer);

24   Put_Line (Unsigned_Integer'Image);

25

26   declare

27      Some_String : constant String :=

28        Unsigned_Integer_Type'Image (Unsigned_Integer);

29   begin

30      Signed_Integer := Signed_Integer_Type'Value (Some_String);

31      Put_Line (Signed_Integer'Image);

32

33      Put_Line (Some_String);

34   end;

35

36end Discrete_Numeric_Types;

Footnotes

real_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Real_Types is

3

4   Predefined_Floating_Point : constant Float := 0.0;

5

6   type Floating_Point_Type is digits 8 range -1.0e10 .. 1.0e10;

7   Floating_Point : Floating_Point_Type := 1.234e2;

8

9begin

10

11   Put_Line (Integer'Image (Floating_Point_Type'Digits));

12   Put_Line (Integer'Image (Floating_Point_Type'Base'Digits));

13   Floating_Point := Floating_Point_Type'Succ (Floating_Point);

14   Put_Line (Floating_Point_Type'Image (Floating_Point));

15   Put_Line (Predefined_Floating_Point'Image);

16

17end Real_Types;

Footnotes

assignment_statements.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Assignment_Statements is

3

4   Max_Miles : constant Integer := 20;

5

6   type Feet_T is range 0 .. Max_Miles * 5_280;

7   type Miles_T is range 0 .. Max_Miles;

8

9   Feet  : constant Feet_T := Feet_T (Line) * 1_000;

10   Miles : Miles_T         := 0;

11

12   Index1, Index2 : Miles_T range 1 .. 20;

13

14begin

15

16   -- Miles := Feet / 5_280; -- compile error

17

18   -- Max_Miles := Max_Miles + 1; -- compile error

19

20   Index1 := Miles_T (Max_Miles); -- constraint checking added

21   Index2 := Index1;    -- no constraint checking needed

22

23   Put_Line ("Index1 = " & Index1'Image);

24   Put_Line ("Index2 = " & Index2'Image);

25

26   Index1 := 0; -- run-time error

27   Put_Line ("Index1 = " & Index1'Image);

28

29end Assignment_Statements;

Footnotes

conditional_statements.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Conditional_Statements is

3   type Light_T is (Red, Yellow, Green);

4   A, B  : Integer          := Integer (Line);

5   Speed : Integer;

6   Light : constant Light_T := Light_T'Val (Line);

7

8begin

9   if Light = Red then

10      Speed := 0;

11   elsif Light = Green then

12      Speed := 25;

13   else

14      Speed := 50;

15   end if;

16

17   case Light is

18      when Red =>    Speed := 0;

19      when Green =>  Speed := 25;

20      when Yellow => Speed := 50;

21   end case;

22

23   case A is

24      when 1 .. 100   => B := A;

25      when -100 .. -1 => B := -A;

26      when others     => A := B;

27   end case;

28

29   Put_Line ("Speed = " & Speed'Image);

30   Put_Line ("Light = " & Light'Image);

31

32end Conditional_Statements;

Footnotes

loop_statements.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Loop_Statements is

3   File    : File_Type;

4   Counter : Integer := 0;

5   type Light_T is (Red, Yellow, Green);

6begin

7   loop

8      if not Is_Open (File) then

9         exit;

10      end if;

11      Counter := Counter + 1;

12      exit when Is_Open (File);

13   end loop;

14

15   while Is_Open (File) loop

16      Counter := Counter - 1;

17   end loop;

18

19   for Light in Light_T loop

20      Put_Line (Light_T'Image (Light));

21   end loop;

22

23   for Counter in reverse 1 .. 10 loop

24      Put_Line (Integer'Image (Counter));

25      exit when Is_Open (File);

26   end loop;

27end Loop_Statements;

Footnotes

aggregates.adb

1procedure Aggregates is

2

3   type Days_T is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);

4   type Working_T is array (Days_T) of Float;

5   Week : Working_T := (others => 0.0);

6

7   Start, Finish : Days_T;

8

9   type Array_T is array (Days_T range <>) of Boolean;

10   List : Array_T (Mon .. Start) := (others => False);

11

12begin

13

14   Week := (8.0, 8.0, 8.0, 8.0, 8.0, 0.0, 0.0);

15   Week := (Sat => 0.0, Sun => 0.0, Mon .. Fri => 8.0);

16   Week := (Sat | Sun => 0.0, Mon .. Fri => 8.0);

17   -- Compile error

18   -- Week := (8.0, 8.0, 8.0, 8.0, 8.0, Sat => 0.0, Sun => 0.0);

19

20   if Week = (10.0, 10.0, 10.0, 10.0, 0.0, 0.0, 0.0) then

21      null; -- four-day week

22   end if;

23

24   Week := (8.0, others => 0.0);

25   Week := (8.0, others => <>); -- Ada2012: use previously set values

26

27   -- Compile error

28   -- Week := (Week'First .. Start => 0.0, Start .. Finish => 8.0,

29   --          Finish .. Week'Last => 0.0);

30

31end Aggregates;

Footnotes

attributes.adb

1procedure Attributes is

2

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

4   Bits8 : Array_Of_Bits_T (0 .. 7);

5

6   type Array_Of_Bitstrings_T is

7     array (Natural range <>, Natural range <>) of Boolean;

8   Bitstrings : Array_Of_Bitstrings_T (1 .. 10, 0 .. 16);

9

10   Value : Natural;

11

12begin

13

14   Value := 0;

15   for Index in Bits8'First .. Bits8'Last loop

16      if Bits8 (Index) then

17         Value := Value + 2**(Index - Bits8'First);

18      end if;

19   end loop;

20

21   for String_Index in Bitstrings'Range (1) loop

22      Value := 0;

23      for Bit_Index in Bitstrings'Range (2) loop

24         if Bitstrings (String_Index, Bit_Index) then

25            Value := Value + 2**(Bit_Index - Bitstrings'First (2));

26         end if;

27      end loop;

28   end loop;

29

30end Attributes;

Footnotes

constrained_array_types.ads

1package Constrained_Array_Types is

2

3   type Array_Of_Integers_T is array (1 .. 10) of Integer;

4   type Array_Of_Bits_T is

5         array (Natural range 0 .. 31) of Boolean;

6

7   type Color_T is (Red, Green, Blue);

8   type Color_Range_T is mod 256;

9   type Rgb_T is array (Color_T) of Color_Range_T;

10

11   Ten_Integers : Array_Of_Integers_T;

12   One_Word     : Array_Of_Bits_T;

13   Color        : Rgb_T;

14

15end Constrained_Array_Types;

Footnotes

operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Operations is

3

4   type Boolean_Array_T is array (0 .. 15) of Boolean;

5   Bool1, Bool2, Bool3 : Boolean_Array_T;

6

7   type Integer_Array_T is array (1 .. 100) of Integer;

8   Int1, Int2 : Integer_Array_T;

9

10   Str1 : String (1 .. 10) := (others => 'X');

11   Str2 : String (2 .. 9)  := (others => '-');

12

13   Flag : Boolean;

14

15begin

16

17   Bool3 := Bool1 or Bool2;

18   Flag  := Int1 > Int2;

19   Put_Line (Flag'Image);

20

21   declare

22      Str3 : String := Str1 & Str2;

23   begin

24      Str3

25        (Str3'First .. Str3'First + 1) := "**";

26      Str3 (1 .. 4)                    := Str1 (1 .. 2) & Str2 (8 .. 9);

27      Put_Line (Str3);

28   end;

29

30   if Int1 (1) in Bool3'Range then

31      Bool3 (Int1 (1)) := Int1 (1) > Int2 (1);

32      Put_Line (Boolean'Image (Bool3 (Int1 (1))));

33   end if;

34

35end Operations;

Footnotes

operations_added_for_ada2012.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Operations_Added_For_Ada2012 is

3

4   type Integer_Array_T is array (1 .. 10) of Integer with

5      Default_Component_Value => -1;

6   Int_Array : Integer_Array_T;

7

8   type Matrix_T is array (1 .. 3, 1 .. 3) of Integer with

9      Default_Component_Value => -1;

10   Matrix : Matrix_T;

11

12begin

13

14   for Index in Int_Array'First + 1 .. Int_Array'Last - 1 loop

15      Int_Array (Index) := Index * 10;

16   end loop;

17   for Item of Int_Array loop

18      Put_Line (Integer'Image (Item));

19   end loop;

20

21   for Index1 in Matrix_T'First (1) + 1 .. Matrix'Last (1) loop

22      for Index2 in Matrix_T'First (2) + 1 .. Matrix'Last (2) loop

23         Matrix (Index1, Index2) := Index1 * 100 + Index2;

24      end loop;

25   end loop;

26   for Item of reverse Matrix loop

27      Put_Line (Integer'Image (Item));

28   end loop;

29

30end Operations_Added_For_Ada2012;

Footnotes

unconstrained_array_types.ads

1package Unconstrained_Array_Types is

2

3   type Index_T is range 1 .. 100;

4   type List_T is array (Index_T range <>) of Character;

5   Wrong : List_T (0 .. 10); -- runtime error

6   Right : List_T (11 .. 20);

7

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

9   Bits8  : Array_Of_Bits_T (0 .. 7);

10   Bits16 : Array_Of_Bits_T (1 .. 16);

11

12   type Days_T is (Sun, Mon, Tues, Wed, Thu, Fri, Sat);

13   type Schedule_T is array (Days_T range <>) of Float;

14   Schedule : Schedule_T (Mon .. Fri);

15

16   Name : String (1 .. 10);

17

18   type Roman_Digit is ('I', 'V', 'X', 'L', 'C', 'D', 'M');

19   type Roman_Number is array (Natural range <>) of Roman_Digit;

20   Orwellian : constant Roman_Number := "MCMLXXXIV";

21

22end Unconstrained_Array_Types;

Footnotes

aggregates.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Aggregates is

3

4   type Date_T is record

5      Day   : Integer range 1 .. 31;

6      Month : Positive range 1 .. 12;

7      Year  : Natural range 0 .. 2_099;

8   end record;

9   type Personal_Information_T is record

10      Name      : String (1 .. 10);

11      Birthdate : Date_T;

12   end record;

13   type Employee_Information_T is record

14      Number               : Positive;

15      Personal_Information : Personal_Information_T;

16   end record;

17   Birthdate            : Date_T;

18   Personal_Information : Personal_Information_T;

19   Employee             : Employee_Information_T;

20begin

21   Birthdate := (25, 12, 2_001);

22   Put_Line

23     (Birthdate.Year'Image & Birthdate.Month'Image & Birthdate.Day'Image);

24   Personal_Information := (Name => "Jane Smith", Birthdate => (14, 2, 2_002));

25   Put_Line

26     (Personal_Information.Birthdate.Year'Image &

27      Personal_Information.Birthdate.Month'Image &

28      Personal_Information.Birthdate.Day'Image);

29   Employee := (1_234, Personal_Information => Personal_Information);

30   Put_Line

31     (Employee.Personal_Information.Birthdate.Year'Image &

32      Employee.Personal_Information.Birthdate.Month'Image &

33      Employee.Personal_Information.Birthdate.Day'Image);

34   Birthdate := (Month => 1, others => 2);

35   Put_Line

36     (Birthdate.Year'Image & Birthdate.Month'Image & Birthdate.Day'Image);

37end Aggregates;

Footnotes

components_rules.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Components_Rules is

3   type File_T is record

4      Name    : String (1 .. 12);

5      Mode    : File_Mode;

6      Size    : Integer range 0 .. 1_024;

7      Is_Open : Boolean;

8      -- Anonymous_Component : array (1 .. 3) of Integer;

9      -- Constant_Component  : constant Integer := 123;

10      -- Self_Reference      : File_T;

11   end record;

12   File : File_T;

13begin

14   File.Name    := "Filename.txt";

15   File.Mode    := In_File;

16   File.Size    := 0;

17   File.Is_Open := False;

18   Put_Line (File.Name);

19end Components_Rules;

Footnotes

default_values.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Default_Values is

3

4   type Complex is record

5      Real      : Float := -1.0;

6      Imaginary : Float := -1.0;

7   end record;

8

9   Phasor : Complex;

10   I      : constant Complex := (0.0, 1.0);

11

12begin

13   Put_Line

14     (Float'Image (Phasor.Real) & " " & Float'Image (Phasor.Imaginary) & "i");

15   Put_Line (Float'Image (I.Real) & " " & Float'Image (I.Imaginary) & "i");

16   Phasor := (12.34, others => <>);

17   Put_Line

18     (Float'Image (Phasor.Real) & " " & Float'Image (Phasor.Imaginary) & "i");

19end Default_Values;

Footnotes

operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Operations is

3   type Date_T is record

4      Day   : Integer range 1 .. 31;

5      Month : Positive range 1 .. 12;

6      Year  : Natural range 0 .. 2_099;

7   end record;

8   type Personal_Information_T is record

9      Name      : String (1 .. 10);

10      Birthdate : Date_T;

11   end record;

12   type Employee_Information_T is record

13      Number               : Positive;

14      Personal_Information : Personal_Information_T;

15   end record;

16   Employee : Employee_Information_T;

17begin

18   Employee.Number                              := 1_234;

19   Employee.Personal_Information.Name           := "Fred Smith";

20   Employee.Personal_Information.Birthdate.Year := 2_020;

21   Put_Line (Employee.Number'Image);

22end Operations;

Footnotes

variant_records.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Variant_Records is

3   type Person_Tag is (Student, Faculty);

4   type Person (Tag : Person_Tag) is -- Tag is the discriminant

5   record

6      Name : String (1 .. 10); -- Always present

7      case Tag is

8         when Student => -- 1st variant

9            Gpa  : Float range 0.0 .. 4.0;

10            Year : Integer range 1 .. 4;

11         when Faculty => -- 2nd variant

12            Pubs : Integer;

13      end case;

14   end record;

15   S : Person (Student) :=

16     (Tag => Student, Name => (others => 'S'), Gpa => 4.0, Year => 4);

17   F : Person (Faculty) :=

18     (Tag => Faculty, Name => (others => 'F'), Pubs => 10);

19begin

20   Put_Line (S.Name & " " & F.Name);

21   Put_Line (S.Gpa'Image);

22   Put_Line (S.Pubs'Image); -- run-time error

23   Put_Line (F.Pubs'Image);

24   Put_Line (F.Year'Image); -- run-time error

25end Variant_Records;

Footnotes

declarations_and_bodies.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Declarations_And_Bodies is

3

4   -- declarations

5   procedure Swap (A, B : in out Integer);

6   function Triple (X : Float) return Float;

7

8   -- bodies

9   procedure Swap (A : in out Integer; B : in out Integer) is

10      C : constant Integer := A;

11   begin

12      A := B;

13      B := C;

14   end Swap;

15   function Triple (X : Float) return Float is

16   begin

17      return X * 3.0;

18   end Triple;

19

20   function Factorial (Counter : Natural) return Natural;

21   function Factorial (Counter : Natural) return Natural is

22   begin

23      if Counter = 1 then

24         return 1;

25      else

26         return Counter * Factorial (Counter - 1);

27      end if;

28   end Factorial;

29

30   I1, I2 : Integer := 123;

31

32begin

33   Swap (I1, I2);

34   Put_Line (Float'Image (Triple (12.3)));

35   Put_Line (Natural'Image (Factorial (5)));

36

37end Declarations_And_Bodies;

Footnotes

expression_functions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Expression_Functions is

3

4   function Square1 (X : Integer) return Integer is (X * 2);

5   function Square2 (X : Integer) return Integer is

6   begin

7      return X * 2;

8   end Square2;

9

10   function Square3 (X : Integer) return Integer;

11   function Square3 (X : Integer) return Integer is (X * 2);

12

13   function Square4 (X : Integer) return Integer is (X * 2);

14   -- illegal: Square4 already complete function Square4 (X : Integer) return

15   -- Integer is begin

16   --    return X * 2;

17   -- end Square4;

18

19begin

20   Put_Line (Integer'Image (Square1 (2)));

21   Put_Line (Integer'Image (Square2 (3)));

22   Put_Line (Integer'Image (Square3 (4)));

23   Put_Line (Integer'Image (Square4 (5)));

24end Expression_Functions;

Footnotes

parameters.adb

1procedure Parameters is

2

3   procedure Do_Something (Formal_I : in Integer; Formal_B : out Boolean) is

4   begin

5      Formal_B := Formal_I > 0;

6   end Do_Something;

7

8   procedure All_Modes (Number : in     Integer;

9                        Value  : in out Integer;

10                        Result :    out Boolean) is

11   begin

12      Value  := Value * Number;

13      Result := Value > 0;

14   end All_Modes;

15

16   procedure Defaults (A : Integer := 1;

17                       B : Integer := 2;

18                       C : Boolean := True;

19                       D : Boolean := False) is null;

20

21   type Vector is array (Positive range <>) of Float;

22   procedure Add (Left : in out Vector; Right : Vector) is

23   begin

24      for I in Left'First .. Left'Last loop

25         Left (I) := Left (I) + Right (I);

26      end loop;

27   end Add;

28

29   Actual_I1, Actual_I2 : Integer := 0;

30   Actual_B             : Boolean;

31   Actual_V             : Vector (1 .. 100);

32

33begin

34   Do_Something (Actual_I1,

35                 Formal_B => Actual_B);

36   All_Modes (Actual_I1 + 100, Actual_I2, Actual_B);

37   -- All_Modes (Actual_I1, Actual_I2 + 100, Actual_B); -- compile error

38   Defaults (1, 2, True, False);

39   Defaults;

40   -- Defaults (1, True); -- compile error

41   Defaults (A => 1,

42             D => True);

43   Add (Actual_V (1 .. 10), Actual_V (11 .. 20));

44end Parameters;

Footnotes

potential_pitfalls.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Potential_Pitfalls is

3   Global_I : Integer  := 0;

4   Global_P : Positive := 1;

5   Global_S : String   := "Hello";

6

7   procedure Unassigned_Out (A : in Integer; B : out Positive) is

8   begin

9      if A > 0 then

10         B := A;

11      end if;

12   end Unassigned_Out;

13

14   function Cause_Side_Effect return Integer is

15   begin

16      Global_I := Global_I + 1;

17      return Global_I;

18   end Cause_Side_Effect;

19

20   procedure Order_Dependent_Code (X, Y : Integer) is

21   begin

22      Put_Line (Integer'Image (X) & " / " & Integer'Image (Y));

23   end Order_Dependent_Code;

24

25   procedure Aliasing (Param : in     String;

26                       I1    : in out Integer;

27                       I2    : in out Integer) is

28   begin

29      Global_S := "World";

30      I1       := I1 * 2;

31      I2       := I2 * 3;

32      Put_Line ("Aliasing string: " & Param);

33   end Aliasing;

34

35begin

36   Unassigned_Out (-1, Global_P);

37   Put_Line ("Global_P = " & Positive'Image (Global_P));

38

39   Order_Dependent_Code (Global_I, Cause_Side_Effect);

40

41   Global_P := Positive'First;

42   -- Aliasing (Global_S, Global_I, Global_I); -- compile error

43   Aliasing (Global_S, Global_I, Global_P);

44   Put_Line ("Global_S: " & Global_S);

45   Put_Line ("Global_P: " & Global_P'Image);

46end Potential_Pitfalls;

Footnotes

conditional_expressions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Conditional_Expressions is

3

4   type Months_T is

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

6   Year : constant Integer := 2_020;

7

8   procedure If_Expression is

9      Counter : Natural := 5;

10   begin

11      while Counter > 0 loop

12         Put_Line

13           ("Self-destruct in" & Natural'Image (Counter) &

14            (if Counter = 1 then " second" else " seconds"));

15         delay 1.0;

16         Counter := Counter - 1;

17      end loop;

18      Put_Line ("Boom! (goodbye Nostromo)");

19   end If_Expression;

20

21   procedure Case_Expression is

22      Leap_Year : constant Boolean :=

23        (Year mod 4 = 0 and Year mod 100 /= 0) or else (Year mod 400 = 0);

24   begin

25      for M in Months_T loop

26         Put_Line

27           (M'Image & " => " &

28            Integer'Image

29              (case M is when Sep | Apr | Jun | Nov => 30,

30                 when Feb    => (if Leap_Year then 29 else 28),

31                 when others => 31));

32      end loop;

33   end Case_Expression;

34

35begin

36   If_Expression;

37   Case_Expression;

38end Conditional_Expressions;

Footnotes

membership_tests.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Membership_Tests is

3   subtype Index_T is Integer range 1 .. 100;

4   X : constant Integer := Integer (Line);

5   B : Boolean          := X in 1 .. 100;

6   C : Boolean          := not (X in Index_T);

7   D : Boolean          := X not in Index_T;

8

9   type Calendar_Days is (Sun, Mon, Tues, Wed, Thur, Fri, Sat);

10   subtype Weekdays is Calendar_Days range Mon .. Fri;

11   Day : Calendar_Days := Calendar_Days'Val (X);

12

13begin

14

15   if Day in Sun | Sat then

16      -- identical expressions

17      B   := Day in Mon .. Fri;

18      C   := Day in Weekdays;

19      Day := Wed;

20   elsif Day = Mon or Day = Tues then

21      D   := D and (B or C);

22      Day := Thur;

23   end if;

24

25   Put_Line (D'Image & " " & B'Image & " " & C'Image);

26   Put_Line (Day'Image);

27

28end Membership_Tests;

Footnotes

quantified_expressions.adb

1with GNAT.Random_Numbers; use GNAT.Random_Numbers;

2with Ada.Text_IO;         use Ada.Text_IO;

3procedure Quantified_Expressions is

4   Gen    : Generator;

5   Values : constant array (1 .. 10) of Integer := (others => Random (Gen));

6

7   Any_Even : constant Boolean := (for some N of Values => N mod 2 = 0);

8   All_Odd  : constant Boolean := (for all N of reverse Values => N mod 2 = 1);

9

10   function Is_Sorted return Boolean is

11     (for all K in Values'Range =>

12        K = Values'First or else Values (K - 1) <= Values (K));

13

14   function Duplicate return Boolean is

15     (for some I in Values'Range =>

16        (for some J in I + 1 .. Values'Last => Values (I) = Values (J)));

17

18begin

19   Put_Line ("Any Even: " & Boolean'Image (Any_Even));

20   Put_Line ("All Odd: " & Boolean'Image (All_Odd));

21   Put_Line ("Is_Sorted " & Boolean'Image (Is_Sorted));

22   Put_Line ("Duplicate " & Boolean'Image (Duplicate));

23end Quantified_Expressions;

Footnotes

slices.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Slices is

3   procedure Explicit_Indices is

4      Full_Name : String (1 .. 20) := "Barney    Rubble    ";

5   begin

6      Put_Line (Full_Name);

7      Full_Name (1 .. 10) := "Betty     ";

8      Put_Line (Full_Name (1 .. 10)); -- first half of name

9      Put_Line (Full_Name (11 .. 20)); -- second half of name

10   end Explicit_Indices;

11

12   procedure Subtype_Indices is

13      subtype First_Name is Positive range 1 .. 10;

14      subtype Last_Name is Positive range 11 .. 20;

15      Full_Name : String (First_Name'First .. Last_Name'Last) :=

16        "Fred      Flintstone";

17   begin

18      Put_Line (Full_Name);

19      Full_Name (First_Name) := "Wilma     ";

20      Put_Line (Full_Name (First_Name)); -- first half of name

21      Put_Line (Full_Name (Last_Name)); -- second half of name

22   end Subtype_Indices;

23begin

24   Explicit_Indices;

25   Subtype_Indices;

26end Slices;

Footnotes

subtypes.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Subtypes is

3   type Days_T is (Sun, Mon, Tues, Wed, Thurs, Fri, Sat);

4   subtype Weekdays_T is Days_T range Mon .. Fri;

5

6   Weekday      : Weekdays_T              := Mon;

7   Also_Weekday : Days_T range Mon .. Fri := Tues;

8   Day          : Days_T                  := Weekday;

9

10   type Matrix_T is array (Integer range <>, Integer range <>) of Integer;

11   subtype Matrix_3x3_T is Matrix_T (1 .. 3, 1 .. 3);

12   subtype Line_T is String (1 .. 80);

13

14   I : Integer := 1_234;

15   procedure Takes_Positive (P : Positive) is null;

16

17   type Tertiary_Switch is (Off, On, Neither) with

18      Default_Value => Neither;

19   subtype Toggle_Switch is Tertiary_Switch range Off .. On;

20   Safe : Toggle_Switch := Off;

21   -- Implicit : Toggle_Switch; -- compile error: out of range

22

23   pragma Unreferenced (Safe);

24

25begin

26   Also_Weekday := Day;  -- runtime error if Day is Sat or Sun

27   Put_Line (Also_Weekday'Image);

28   Day := Weekday;  -- always legal

29   I   := I - 1;

30   Takes_Positive (I); -- runtime error if I <= 0

31

32   Weekday := Weekdays_T'Last;

33   Day     := Days_T'Last;

34

35   Put_Line (Weekdays_T'Image (Weekday) & " / " & Days_T'Image (Day));

36   Put_Line (Days_T'Image (Weekdays_T'Succ (Weekday)));

37   Put_Line (Integer'Image (Matrix_3x3_T'Length (1)));

38   Put_Line (Integer'Image (Line_T'Length (1)));

39end Subtypes;

Footnotes

call_resolution.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Call_Resolution is

3   type Colors_T is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);

4   type Rgb_T is (Red, Green, Blue);

5   function Str (P : Colors_T) return String is (Colors_T'Image (P));

6   function Str (P : Rgb_T) return String is (Rgb_T'Image (P));

7   procedure Print (Color : Colors_T) is

8   begin

9      Put_Line (Str (Color));

10   end Print;

11   procedure Print (Rgb : Rgb_T) is

12   begin

13      Put_Line (Str (Rgb));

14   end Print;

15   procedure Print (P1 : Colors_T; P2 : Rgb_T) is null;

16

17begin

18   Put_Line (Str (Yellow));

19   -- Put_Line (Str (Red)); -- compile error

20   Print (Orange);

21   Print (Rgb => Red);

22   Print (Color => Blue);

23   Print (Red, Red);

24end Call_Resolution;

Footnotes

composition_of_equality.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Composition_Of_Equality is

3   type My_Integer is range -1_000 .. 1_000;

4   function "=" (L, R : My_Integer) return Boolean is

5     (False); -- for illustration purposes

6   type Record_T is tagged record

7      Field : My_Integer := 0;

8   end record;

9   type Record_List is array (My_Integer range 1 .. 10) of Record_T;

10

11   I1, I2 : constant My_Integer  := 0;

12   R1, R2 : constant Record_List := (others => (Field => 0));

13begin

14   -- uses primitive "=" => False

15   Put_Line (Boolean'Image (I1 = I2));

16   -- uses predefined "=" for components=>True

17   Put_Line (Boolean'Image (R1 = R2));

18end Composition_Of_Equality;

Footnotes

enumerals_and_operators.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Enumerals_And_Operators is

3   type Colors_T is (Blue, Yellow, Black, Green, Red);

4   type Rgb_T is (Red, Green, Blue);

5   type Stoplight_T is (Green, Yellow, Red);

6

7   Color : constant Colors_T    := Red;

8   Rgb   : constant Rgb_T       := Red;

9   Light : constant Stoplight_T := Red;

10

11   type Miles_T is digits 6;

12   type Hour_T is digits 6;

13   type Speed_T is digits 6;

14   function "/" (M : Miles_T; H : Hour_T) return Speed_T is

15      (Speed_T (Float (M) / Float (H)));

16   function "*" (Mph : Speed_T; H   : Hour_T) return Miles_T is

17      (Miles_T (Float (Mph) * Float (H)));

18

19   M   : Miles_T         := Miles_T (Col);

20   H   : constant Hour_T := Hour_T (Line);

21   Mph : Speed_T;

22

23begin

24   Put_Line (Color'Image & " " & Rgb'Image & " " & Light'Image);

25   Mph := M / H;

26   M   := Mph * H;

27   Put_Line (Mph'Image & M'Image);

28

29   Mph := "/" (M => M, H => H);

30   M := "*" (Mph, H);

31   Put_Line (Mph'Image & M'Image);

32end Enumerals_And_Operators;

Footnotes

user_defined_equality.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure User_Defined_Equality is

3   type Array_T is array (1 .. 10) of Integer;

4   type List_T is record

5      List  : Array_T;

6      Count : Integer := 0;

7   end record;

8

9   function "=" (L, R : List_T) return Boolean is

10   begin

11      if L.Count /= R.Count then

12         Put_Line ("Count is off");

13         return False;

14      else

15         for I in 1 .. L.Count loop

16            if L.List (I) /= R.List (I) then

17               Put_Line ("elements don't match");

18               return False;

19            end if;

20         end loop;

21      end if;

22      return True;

23   end "=";

24   L, R : List_T := (List => (others => 1), Count => 3);

25begin

26   Put_Line (Boolean'Image (L = R));

27   L.List (2) := 0;

28   Put_Line (Boolean'Image (L = R));

29   R.Count := 1;

30   Put_Line (Boolean'Image (L = R));

31end User_Defined_Equality;

Footnotes

visibility_issues.adb

1procedure Visibility_Issues is

2   procedure Foo (I : Integer) is

3      procedure Foo (N : Natural) is null;

4   begin

5      Foo (I);

6   end Foo;

7   -- procedure Foo (N : Natural) is null; -- compile error

8begin

9   Foo (1);

10end Visibility_Issues;

Footnotes

named_common.ads

1package Named_Common is

2   X : Integer; -- valid object for life of application

3   Y : Float;    -- valid object for life of application

4end Named_Common;

library_procedure.ads

1procedure Library_Procedure (Parameter : in out Integer);

library_procedure.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Library_Procedure (Parameter : in out Integer) is

3   -- X is visible to Library_Procedure and Nested_Procedure

4   X : constant Integer := Parameter;

5   procedure Nested_Procedure is

6      -- Y is only visible to Nested_Procedure

7      Y : constant Integer := X * 2;

8   begin

9      Parameter := X * Y;

10   end Nested_Procedure;

11begin

12   Nested_Procedure;

13   Put_Line ("parameter = " & Parameter'Image);

14end Library_Procedure;

main.adb

1with Library_Procedure;

2with Named_Common;

3procedure Main is

4begin

5   Named_Common.X := 123;

6   Library_Procedure (Named_Common.X);

7end Main;

Footnotes

base_types.ads

1with Ada.Text_IO;

2package Base_Types is

3   type Position_T is record

4      Line   : Ada.Text_IO.Positive_Count;

5      Column : Ada.Text_IO.Positive_Count;

6   end record;

7end Base_Types;

files.ads

1-- no need to "with" ada.text_io

2with Base_Types;

3package Files is

4   subtype Name_T is String (1 .. 12);

5   type File_T is record

6      Name     : Name_T                := (others => ' ');

7      Position : Base_Types.Position_T := (Line => 1, Column => 1);

8   end record;

9   function Create (Name : Name_T) return File_T;

10end Files;

files.adb

1package body Files is

2   -- "with" of base_types inherited from spec

3   Default_Position : constant Base_Types.Position_T := (1, 1);

4   function Create (Name : Name_T) return File_T is

5     (Name => Name, Position => Default_Position);

6end Files;

Footnotes

body_not_allowed.ads

1package Body_Not_Allowed is

2   type Real is digits 12;

3   type Device_Coordinates is record

4      X, Y : Integer;

5   end record;

6   type Normalized_Coordinates is record

7      X, Y : Real range 0.0 .. 1.0;

8   end record;

9   -- nothing to implement, so no body allowed

10end Body_Not_Allowed;

body_required.ads

1package Body_Required is

2   subtype Rows is Integer range 1 .. 24;

3   subtype Columns is Integer range 1 .. 80;

4   type Position is record

5      Row : Rows    := Rows'First;

6      Col : Columns := Columns'First;

7   end record;

8   -- The following need to be defined in the body

9   procedure Move_Cursor (To : in Position);

10   procedure Home;

11end Body_Required;

body_required.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Body_Required is

3   -- This function is not visible outside this package

4   function Unsigned (Input : Integer) return String is

5      Str : constant String := Integer'Image (Input);

6   begin

7      return Str (2 .. Str'Length);

8   end Unsigned;

9   procedure Move_Cursor (To : in Position) is

10   begin

11      Put (ASCII.ESC & "I" & Unsigned(To.Row) & ";" & Unsigned(To.Col) & "H");

12   end Move_Cursor;

13   procedure Home is null; -- not yet implemented

14end Body_Required;

Footnotes

global_data.ads

1package Global_Data is

2   Object : Integer := 100;

3   type Float_T is digits 6;

4end Global_Data;

float_stack.ads

1with Global_Data;

2package Float_Stack is

3   Max : constant Integer := Global_Data.Object;

4   procedure Push (X : in Global_Data.Float_T);

5   function Pop return Global_Data.Float_T;

6end Float_Stack;

float_stack.adb

1package body Float_Stack is

2   Local_Object : Global_Data.Float_T;

3   procedure Not_Exported is null;

4   procedure Push (X : in Global_Data.Float_T) is

5   begin

6      Not_Exported;

7      Local_Object := X;

8   end Push;

9   function Pop return Global_Data.Float_T is (Local_Object);

10end Float_Stack;

Footnotes

executable_part.ads

1package Executable_Part is

2   Visible_Seed : Integer;

3   function Number return Float;

4end Executable_Part;

executable_part.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Executable_Part is

3   Hidden_Seed : Integer;

4   procedure Initialize (Seed1 : out Integer; Seed2 : out Integer) is

5   begin

6      Seed1 := Integer'First;

7      Seed2 := Integer'Last;

8   end Initialize;

9   function Number return Float is (0.0); -- not yet implemented

10begin

11   Put_Line ("Elaborating Executable_Part");

12   Initialize (Visible_Seed, Hidden_Seed);

13end Executable_Part;

force_body.ads

1package Force_Body is

2   pragma Elaborate_Body;

3   Global_Data : array (1 .. 10) of Integer;

4end Force_Body;

force_body.adb

1-- without Elaborate_Body, this is illegal

2with Ada.Text_IO; use Ada.Text_IO;

3package body Force_Body is

4begin

5   Put_Line ("Elaborating Force_Body");

6   for I in Global_Data'Range loop

7      Global_Data (I) := I * 100;

8   end loop;

9end Force_Body;

main.adb

1with Executable_Part;

2with Force_Body;

3procedure Main is

4begin

5   null;

6end Main;

Footnotes

constants.ads

1package Constants is

2   Polar_Radius      : constant := 20_856_010.51;

3   Equatorial_Radius : constant := 20_926_469.20;

4   Earth_Diameter    : constant :=

5     2.0 * ((Polar_Radius + Equatorial_Radius) / 2.0);

6end Constants;

global_data.ads

1package Global_Data is

2   Longitudinal_Velocity     : Float := 0.0;

3   Longitudinal_Acceleration : Float := 0.0;

4   Lateral_Velocity          : Float := 0.0;

5   Lateral_Acceleration      : Float := 0.0;

6   Vertical_Velocity         : Float := 0.0;

7   Vertical_Acceleration     : Float := 0.0;

8end Global_Data;

related_units.ads

1package Related_Units is

2   type Vector is array (Positive range <>) of Float;

3   function "+" (L, R : Vector) return Vector;

4   function "-" (L, R : Vector) return Vector;

5end Related_Units;

related_units.adb

1package body Related_Units is

2   -- nothing is implemented yet!

3   function "+" (L, R : Vector) return Vector is (L);

4   function "-" (L, R : Vector) return Vector is (L);

5end Related_Units;

stack_abstract_data_machine.ads

1package Stack_Abstract_Data_Machine is

2   procedure Push (X : in Float);

3   procedure Pop (X : out Float);

4   function Empty return Boolean;

5   function Full return Boolean;

6end Stack_Abstract_Data_Machine;

stack_abstract_data_machine.adb

1package body Stack_Abstract_Data_Machine is

2   -- nothing is implemented yet!

3   procedure Push (X : in Float) is null;

4   procedure Pop (X : out Float) is null;

5   function Empty return Boolean is (True);

6   function Full return Boolean is (True);

7end Stack_Abstract_Data_Machine;

Footnotes

complex.ads

1package Complex is

2   type Number_T is private;

3   function Constructor (Real_Part, Imaginary_Part : Float )

4                         return Number_T;

5   procedure Constructor (This           : out Number_T;

6                          Real_Part      :     Float;

7                          Imaginary_Part :     Float);

8   function Real_Part (This : Number_T) return Float;

9   function Imaginary_Part (This : Number_T) return Float;

10   function Str (This : Number_T) return String;

11

12private

13   type Number_T is record

14      Real_Part, Imaginary_Part : Float;

15   end record;

16

17   function Constructor (Real_Part, Imaginary_Part : Float )

18                         return Number_T is

19      (Real_Part, Imaginary_Part);

20

21   function Real_Part (This : Number_T) return Float is

22     (This.Real_Part);

23   function Imaginary_Part (This : Number_T) return Float is

24     (This.Imaginary_Part);

25end Complex;

complex.adb

1package body Complex is

2   procedure Constructor (This           : out Number_T;

3                          Real_Part      :     Float;

4                          Imaginary_Part :     Float) is

5   begin

6      This := Constructor (Real_Part, Imaginary_Part);

7   end Constructor;

8

9   function Str (This : Number_T) return String is

10   begin

11      return Float'Image (Real_Part (This)) & " " &

12        Float'Image (Imaginary_Part (This)) & "i";

13   end Str;

14end Complex;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Complex;     use Complex;

3procedure Main is

4   Number : Number_T := Constructor (1.2, 3.4);

5begin

6   Put_Line (Str (Number));

7   Constructor (Number, 56.7, 8.9);

8   Put_Line (Str (Number));

9end Main;

Footnotes

bounded_stack.ads

1package Bounded_Stack is

2   Max_Capacity : constant := 100;

3   type Stack_T is private;

4   procedure Push (This : in out Stack_T; Item : Integer);

5   procedure Pop (This : in out Stack_T; Item : out Integer);

6   function Is_Empty (This : Stack_T) return Boolean;

7private

8   type List_T is array (1 .. Max_Capacity) of Integer;

9   type Stack_T is record

10      List : List_T;

11      Top  : Integer range 0 .. Max_Capacity := 0;

12   end record;

13end Bounded_Stack;

bounded_stack.adb

1package body Bounded_Stack is

2   procedure Push (This : in out Stack_T; Item : Integer) is

3   begin

4      This.Top             := This.Top + 1;

5      This.List (This.Top) := Item;

6   end Push;

7   procedure Pop (This : in out Stack_T; Item : out Integer) is

8   begin

9      Item     := This.List (This.Top);

10      This.Top := This.Top - 1;

11   end Pop;

12   function Is_Empty (This : Stack_T) return Boolean is (This.Top = 0);

13end Bounded_Stack;

main.adb

1with Ada.Text_IO;   use Ada.Text_IO;

2with Bounded_Stack; use Bounded_Stack;

3procedure Main is

4   Stack : Stack_T;

5   Item  : Integer;

6begin

7   Push (Stack, 42);

8   Put_Line (Boolean'Image (Is_Empty (Stack)));

9   Pop (Stack, Item);

10   --Put_Line (Integer'Image (Stack.Top)); -- compile error

11   Put_Line (Boolean'Image (Is_Empty (Stack)));

12   Put_Line (Item'Image);

13end Main;

Footnotes

sets.ads

1package Sets is

2   type Set_T is private;

3   Null_Set : constant Set_T;

4   type Days_T is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);

5   procedure Add (This : in out Set_T; Day : Days_T);

6   procedure Remove (This : in out Set_T; Day : Days_T);

7   function Str (This : Set_T) return String;

8private

9   function Length (This : Set_T) return Natural;

10   type Set_T is array (Days_T) of Boolean;

11   Null_Set : constant Set_T := (others => False);

12end Sets;

sets.adb

1package body Sets is

2   procedure Add (This : in out Set_T; Day : Days_T) is

3   begin

4      This (Day) := True;

5   end Add;

6   procedure Remove (This : in out Set_T; Day : Days_T) is null;

7   function Str (This : Set_T) return String is

8      Ret_Val : String (1 .. Length (This) * 4) := (others => ' ');

9      Pos     : Natural                         := 1;

10   begin

11      for D in This'Range loop

12         if This (D) then

13            Ret_Val (Pos .. Pos + 2) := D'Image;

14            Pos                      := Pos + 4;

15         end if;

16      end loop;

17      return Ret_Val;

18   end Str;

19   function Length (This : Set_T) return Natural is

20      Ret_Val : Natural := 0;

21   begin

22      for D in This'Range loop

23         Ret_Val := Ret_Val + (if This (D) then 1 else 0);

24      end loop;

25      return Ret_Val;

26   end Length;

27end Sets;

main.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Sets;        use Sets;

3procedure Main is

4   Set : Set_T := Null_Set;

5begin

6   Add (Set, Sun);

7   Add (Set, Sat);

8   Add (Set, Mon);

9   Put_Line (Str (Set));

10end Main;

Footnotes

multiprocessor_mutex.ads

1with Interfaces; use Interfaces;

2package Multiprocessor_Mutex is

3   type Limited_T is limited private;

4   procedure Lock (This : in out Limited_T);

5   procedure Unlock (This : in out Limited_T);

6   function Create return Limited_T;

7private

8   type Limited_T is limited -- no internal copying allowed

9   record

10      Flag : Interfaces.Unsigned_8; -- users cannot see this

11   end record;

12end Multiprocessor_Mutex;

multiprocessor_mutex.adb

1package body Multiprocessor_Mutex is

2   procedure Lock (This : in out Limited_T) is null;

3   procedure Unlock (This : in out Limited_T) is null;

4

5   Global_Lock_Counter : Interfaces.Unsigned_8 := 0;

6   function Create return Limited_T is

7   begin

8      return Ret_Val : Limited_T do

9         Global_Lock_Counter := Global_Lock_Counter + 1;

10         Ret_Val.Flag        := Global_Lock_Counter;

11      end return;

12   end Create;

13end Multiprocessor_Mutex;

use_limited_type.ads

1with Multiprocessor_Mutex; use Multiprocessor_Mutex;

2package Use_Limited_Type is

3   type Legal is limited private;

4   type Also_Legal is limited private;

5   -- type Not_Legal is private;

6   -- type Also_Not_Legal is private;

7private

8   type Legal is record

9      S : Limited_T;

10   end record;

11   type Also_Legal is limited record

12      S : Limited_T;

13   end record;

14   -- type Not_Legal is limited record

15   --    S : Limited_T;

16   -- end record;

17   -- type Also_Not_Legal is record

18   --    S : Limited_T;

19   -- end record;

20end Use_Limited_Type;

Footnotes

multiprocessor_mutex.ads

1with Interfaces;

2package Multiprocessor_Mutex is

3   subtype Id_T is String (1 .. 4);

4   -- prevent copying of a lock

5   type Limited_T is limited record

6      Flag : Interfaces.Unsigned_8;

7   end record;

8   type Also_Limited_T is record

9      Lock : Limited_T;

10      Id   : Id_T;

11   end record;

12   procedure Lock (This : in out Also_Limited_T);

13   procedure Unlock (This : in out Also_Limited_T);

14   function Create (Flag : Interfaces.Unsigned_8;

15                    Id   : Id_T)

16                    return Also_Limited_T;

17end Multiprocessor_Mutex;

multiprocessor_mutex.adb

1package body Multiprocessor_Mutex is

2   procedure Lock (This : in out Also_Limited_T) is null;

3   procedure Unlock (This : in out Also_Limited_T) is null;

4   Global_Lock : Also_Limited_T := (Lock => (Flag => 0), Id => "GLOB");

5   function Create (Flag : Interfaces.Unsigned_8;

6                    Id   : Id_T)

7                    return Also_Limited_T is

8      Local_Lock : Also_Limited_T := (Lock => (Flag => 1), Id => "LOCA");

9   begin

10      Global_Lock.Lock.Flag := Flag;

11      Local_Lock.Id         := Id;

12      -- Compile error

13      -- return Local_Lock;

14      -- Compile error

15      -- return Global_Lock;

16      return (Lock => (Flag => Flag), Id => Id);

17   end Create;

18end Multiprocessor_Mutex;

perform_lock.adb

1with Ada.Text_IO;          use Ada.Text_IO;

2with Multiprocessor_Mutex; use Multiprocessor_Mutex;

3procedure Perform_Lock is

4   Lock1 : Also_Limited_T := (Lock => (Flag => 2), Id => "LOCK");

5   Lock2 : Also_Limited_T;

6begin

7   -- Lock2 := Create ( 3, "CREA" ); -- illegal

8   Put_Line (Lock1.Id & Lock1.Lock.Flag'Image);

9end Perform_Lock;

Footnotes

multiprocessor_mutex.ads

1with Interfaces;

2package Multiprocessor_Mutex is

3   subtype Id_T is String (1 .. 4);

4   -- prevent copying of a lock

5   type Limited_T is limited record

6      Flag : Interfaces.Unsigned_8;

7   end record;

8   type Also_Limited_T is record

9      Lock : Limited_T;

10      Id   : Id_T;

11   end record;

12   procedure Lock (This : in out Also_Limited_T) is null;

13   procedure Unlock (This : in out Also_Limited_T) is null;

14end Multiprocessor_Mutex;

Footnotes

multiprocessor_mutex.ads

1with Interfaces; use Interfaces;

2package Multiprocessor_Mutex is

3   subtype Id_T is String (1 .. 4);

4   -- prevent copying of a lock

5   type Limited_T is limited record

6      Flag : Interfaces.Unsigned_8;

7   end record;

8   type Also_Limited_T is record

9      Lock : Limited_T;

10      Id   : Id_T;

11   end record;

12   procedure Lock (This : in out Also_Limited_T);

13   procedure Unlock (This : in out Also_Limited_T);

14   function Create (Id : Id_T) return Also_Limited_T;

15end Multiprocessor_Mutex;

multiprocessor_mutex.adb

1package body Multiprocessor_Mutex is

2   procedure Lock (This : in out Also_Limited_T) is null;

3   procedure Unlock (This : in out Also_Limited_T) is null;

4

5   Global_Lock_Counter : Interfaces.Unsigned_8 := 0;

6   function Create (Id : Id_T) return Also_Limited_T is

7   begin

8      return Ret_Val : Also_Limited_T do

9         if Global_Lock_Counter = Interfaces.Unsigned_8'Last then

10            return;

11         end if;

12         Global_Lock_Counter := Global_Lock_Counter + 1;

13         Ret_Val.Id          := Id;

14         Ret_Val.Lock.Flag   := Global_Lock_Counter;

15      end return;

16   end Create;

17end Multiprocessor_Mutex;

perform_lock.adb

1with Ada.Text_IO;          use Ada.Text_IO;

2with Multiprocessor_Mutex; use Multiprocessor_Mutex;

3procedure Perform_Lock is

4   Lock1 : constant Also_Limited_T := Create ("One ");

5   Lock2 : constant Also_Limited_T := Create ("Two ");

6begin

7   Put_Line (Lock1.Id & Lock1.Lock.Flag'Image);

8   Put_Line (Lock2.Id & Lock2.Lock.Flag'Image);

9end Perform_Lock;

Footnotes

complex.ads

1package Complex is

2   type Number is private;

3   function "+" (Left, Right : Number) return Number;

4   function "-" (Left, Right : Number) return Number;

5private

6   type Number is record

7      Real_Part, Imaginary_Part : Float;

8   end record;

9end Complex;

complex-utils.ads

1package Complex.Utils is

2   function To_String (C : Number) return String;

3end Complex.Utils;

complex-utils.adb

1package body Complex.Utils is

2   -- construction of "number" is visible in the child body

3   function To_String (C : Number) return String is

4     (C.Real_Part'Image & " + i" & C.Imaginary_Part'Image);

5end Complex.Utils;

complex-debug.ads

1package Complex.Debug is

2   -- "with Complex;" not needed for visibility to Number

3   procedure Print (C : Number);

4end Complex.Debug;

complex-debug.adb

1with Ada.Text_IO;

2with Complex.Utils; -- needed for visibility to "To_String"

3package body Complex.Debug is

4   procedure Print (C : Number) is

5   begin

6      -- because of parent visibility, don't need to use "Complex.Utils"

7      Ada.Text_IO.Put_Line (Utils.To_String (C));

8   end Print;

9end Complex.Debug;

complex.adb

1package body Complex is

2   function "+" (Left, Right : Number) return Number is (Left);

3   function "-" (Left, Right : Number) return Number is (Left);

4end Complex;

Footnotes

personnel.ads

1limited with Department;

2package Personnel is

3   type Employee_T is private;

4   procedure Assign (This : in out Employee_T; Section : in Department.Section_T);

5private

6   type Employee_T is record

7      Name        : String (1 .. 10);

8      Assigned_To : access Department.Section_T;

9   end record;

10end Personnel;

department.ads

1limited with Personnel;

2package Department is

3   type Section_T is private;

4   procedure Set_Manager (This : in out Section_T; Who : in Personnel.Employee_T);

5private

6   type Section_T is record

7      Name    : String (1 .. 10);

8      Manager : access Personnel.Employee_T;

9   end record;

10end Department;

personnel.adb

1with Department;

2package body Personnel is

3   procedure Assign (This : in out Employee_T; Section : in Department.Section_T) is

4   begin

5      This.Assigned_To.all := Section;

6   end Assign;

7end Personnel;

department.adb

1with Personnel;

2package body Department is

3   procedure Set_Manager (This : in out Section_T; Who : in Personnel.Employee_T) is

4   begin

5      This.Manager.all := Who;

6   end Set_Manager;

7end Department;

Footnotes

os.ads

1package Os is

2   type File_T is private;

3   function Open (Name : String) return File_T;

4   procedure Write (File : File_T; Str : String);

5   procedure Close (File : File_T);

6private

7   type File_T is new Integer;

8end Os;

os-uart.ads

1private package Os.Uart is

2   type Device_T is private;

3   function Open (Name : String) return Device_T;

4   procedure Write (Device : Device_T; Str : String);

5   procedure Close (Device : Device_T);

6private

7   type Device_T is new Integer;

8end Os.Uart;

os-serial.ads

1private with Os.Uart; -- references only in private section

2private package Os.Serial is

3   type Comport_T is private;

4   procedure Initialize (Comport : in out Comport_T);

5private

6   type Comport_T is record

7      Device : Uart.Device_T;

8   end record;

9end Os.Serial;

os.adb

1package body Os is

2   function Open (Name : String) return File_T is (1);

3   procedure Write (File : File_T; Str : String) is null;

4   procedure Close (File : File_T) is null;

5end Os;

os-uart.adb

1package body Os.Uart is

2   function Open (Name : String) return Device_T is (1);

3   procedure Write (Device : Device_T; Str : String) is null;

4   procedure Close (Device : Device_T) is null;

5end Os.Uart;

os-serial.adb

1package body Os.Serial is

2   procedure Initialize (Comport : in out Comport_T) is null;

3end Os.Serial;

Footnotes

stack.ads

1package Stack is

2   procedure Push (Item : in Integer);

3   procedure Pop (Item : out Integer);

4private

5   Object : array (1 .. 100) of integer;

6   Top    : Natural := 0;

7end Stack;

stack-utils.ads

1package Stack.Utils is

2   function Top return Integer;

3private

4   -- Legal here, but not above "private"

5   function Top return Integer is (Object (Stack.Top));

6end Stack.Utils;

stack-child.ads

1package Stack.Child is

2   procedure Misbehave;

3   procedure Reset;

4   function Peek (Index : Natural) return Integer;

5end Stack.Child;

stack-child.adb

1package body Stack.Child is

2   procedure Misbehave is

3   begin

4      Top := 0;

5   end Misbehave;

6

7   procedure Reset is

8   begin

9      Top := 0;

10   end Reset;

11

12   function Peek (Index : Natural) return Integer is (Object (Index));

13end Stack.Child;

stack.adb

1package body Stack is

2   procedure Push (Item : in Integer) is null;

3   procedure Pop (Item : out Integer) is null;

4end Stack;

Footnotes

complex.ads

1package Complex is

2   type Number is private;

3   function "*" (Left, Right : Number) return Number;

4   function "+" (Left, Right : Number) return Number;

5   procedure Put (C : Number);

6   function Make (Real_Part, Imaginary_Part : Float) return Number;

7   procedure Non_Primitive (X : Integer);

8private

9   type Number is record

10      Real_Part      : Float;

11      Imaginary_Part : Float;

12   end record;

13end Complex;

demo_use_all_type.adb

1with Complex;

2use all type Complex.Number;

3procedure Demo_Use_All_Type is

4   A, B, C : Complex.Number;

5begin

6   -- "use all type" makes these available

7   A := Make (Real_Part      => 1.0,

8              Imaginary_Part => 0.0);

9   B := Make (Real_Part      => 1.0,

10              Imaginary_Part => 0.0);

11   C := A + B;

12   Put (C);

13   -- Non_Primitive (0); -- but not this one

14end Demo_Use_All_Type;

demo_use_type.adb

1with Complex;

2use type Complex.Number;

3procedure Demo_Use_Type is

4   A, B, C : Complex.Number;

5begin

6   -- "use type" makes this available

7   C := A + B;

8   -- but not these

9   -- A := Make (Real_Part      => 1.0,

10   --            Imaginary_Part => 0.0);

11   -- B := Make (Real_Part      => 1.0,

12   --            Imaginary_Part => 0.0);

13   -- Put (C);

14   -- Non_Primitive (0);

15end Demo_Use_Type;

demo_use.adb

1with Complex; use Complex;

2procedure Demo_Use is

3   A, B, C : Complex.Number := (Complex.Make (1.1, 2.2));

4begin

5   -- "use" makes all these available

6   C := A + B;

7   A := Make (Real_Part      => 1.0,

8              Imaginary_Part => 0.0);

9   B := Make (Real_Part      => 1.0,

10              Imaginary_Part => 0.0);

11   Put (C);

12   Non_Primitive (0);

13end Demo_Use;

complex.adb

1package body Complex is

2   function "*" (Left, Right : Number) return Number is (Left);

3   function "+" (Left, Right : Number) return Number is (Left);

4   procedure Put (C : Number) is null;

5   function Make (Real_Part, Imaginary_Part : Float) return Number is

6     ((Real_Part, Imaginary_Part));

7   procedure Non_Primitive (X : Integer) is null;

8end Complex;

Footnotes

pkg_a.ads

1package Pkg_A is

2   Constant_A  : constant := 1;

3   Constant_Aa : constant := 11;

4   Initialized : Boolean  := False;

5end Pkg_A;

pkg_b.ads

1package Pkg_B is

2   Constant_B  : constant := 20;

3   Constant_Bb : constant := 220;

4   Initialized : Boolean  := False;

5end Pkg_B;

pkg_b-child.ads

1package Pkg_B.Child is

2   Constant_Bbb : constant := 222;

3end Pkg_B.Child;

p.ads

1with Pkg_A; use Pkg_A;

2with Pkg_B;

3with Pkg_B.Child;

4package P is

5   type Type_1 is range Constant_A .. -- visible without dot-notation

6                        Pkg_B.Constant_B; -- not visible without dot-notation

7

8   use Pkg_B;

9   -- Constant_B is now visible without dot-notation

10   type Type_2 is range Constant_Aa .. Constant_Bb;

11

12   Constant_Bb : Integer := 33; -- Constant_Bb will always be the local version

13   function Bb return Integer is (Constant_Bb);

14

15   function Is_Initialized return Boolean is

16     (Pkg_A.Initialized and Pkg_B.Initialized); -- Dot-notation to resolve ambiguity

17

18   -- we "use" Pkg_B, so Child is directly visible

19   Object : Integer := Child.Constant_Bbb;

20end P;

test.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with P;

3procedure Test is

4   A, B, C : P.Type_2 := P.Type_2'First;

5begin

6   -- C := A + B; -- illegal

7   C := P."+" (A, B); -- legal but not pretty

8   Put_Line (C'Image);

9   declare

10      use P; -- make everything visible (including operators)

11   begin

12      C := A + B; -- now legal

13      Put_Line (C'Image);

14   end;

15end Test;

Footnotes

p.ads

1package P is

2   type Int1 is range 0 .. 1_000;

3   type Int2 is range 0 .. 2_000;

4   type Int3 is range 0 .. 3_000;

5   function "+" (Left  : Int1; Right : Int3) return Int3;

6   function "+" (Left  : Int2; Right : Int3) return Int3;

7end P;

test.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with P;

3procedure Test is

4   A, B, C : P.Int1 := 123;

5   use type P.Int1;

6   -- D : Int2; -- "Int2" is not visible

7   D : P.Int2 := 234;

8   E : P.Int3 := 345;

9begin

10   B := A;

11   C := A + B; -- implicit operator is visible

12   Put_Line (C'Image);

13   A := B;

14   E := A + E; -- "used" operator visible

15   Put_Line (E'Image);

16   -- E := D + E; -- illegal: operator not "used"

17   -- E := E + A; -- illegal: no matching operator

18end Test;

p.adb

1package body P is

2   function "+" (Left  : Int1; Right : Int3) return Int3 is (Int3'Last);

3   function "+" (Left  : Int2; Right : Int3) return Int3 is (Int3'Last);

4end P;

Footnotes

access_types.ads

1package Access_Types is

2

3   type R is record

4      F1, F2 : Integer;

5   end record;

6   type A_Int is access Integer;

7   type A_String is access all String;

8   type A_R is access R;

9

10   V_Int    : A_Int    := new Integer;

11   V_String : A_String := new String'("abc");

12   V_R      : A_R      := new R;

13

14   procedure Do_Something;

15

16end Access_Types;

access_types.adb

1package body Access_Types is

2

3   function Local_Access_Example return Integer is

4      type String_Access is access String; -- only visible here

5      X : String_Access;

6   begin

7      X := new String'("Hello, World");

8      return X.all'Length;

9   end Local_Access_Example;

10

11   procedure Do_Something is

12   begin

13      V_Int.all    := Local_Access_Example;

14      V_String.all := "cde";

15      V_String (1) := 'z'; -- similar to V_String.all (1) := 'z';

16      V_R.all      := (0, 0);

17      V_R.F1       := 1; -- similar to V_R.all.F1 := 1;

18      V_Int        := null;

19      V_R          := null;

20   end Do_Something;

21

22end Access_Types;

Footnotes

accessibility_checks.ads

1package Accessibility_Checks is

2   procedure Proc_Access;

3   procedure Proc_Unchecked_Access;

4end Accessibility_Checks;

accessibility_checks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Accessibility_Checks is

3

4   type Recursive_Record_T;

5   type Global_Access_T is access all Recursive_Record_T;

6   type Recursive_Record_T is record

7      Field : Integer;

8      Next  : Global_Access_T := null;

9   end record;

10   Global_Pointer : Global_Access_T;

11   Global_Object  : aliased Recursive_Record_T;

12   procedure Proc_Access is

13      type Local_Access_T is access all Recursive_Record_T;

14      Local_Pointer : Local_Access_T;

15      Local_Object  : aliased Recursive_Record_T;

16   begin

17      Global_Pointer := Global_Object'Access;

18      Put_Line (Integer'Image (Global_Pointer.Field));

19      -- Global_Pointer := Local_Object'Access; -- illegal

20      Global_Pointer := Local_Object'Unchecked_Access;

21      Put_Line (Integer'Image (Global_Pointer.Field));

22      Local_Pointer := Global_Object'Access;

23      Put_Line (Integer'Image (Local_Pointer.Field));

24      Local_Pointer := Local_Object'Access;

25      Put_Line (Integer'Image (Local_Pointer.Field));

26      Local_Pointer := Local_Access_T (Global_Pointer);

27      Put_Line (Integer'Image (Local_Pointer.Field));

28      -- Global_Pointer := Global_Access_T (Local_Pointer); -- illegal

29   end Proc_Access;

30

31   procedure Proc_Unchecked_Access is

32      Local_Object : aliased Recursive_Record_T;

33   begin

34      -- Global_Pointer := Local_Object'Access; -- illegal

35      Global_Pointer := Local_Object'Unchecked_Access;

36   end Proc_Unchecked_Access;

37

38end Accessibility_Checks;

Footnotes

anonymous_access_types.ads

1package Anonymous_Access_Types is

2   type Access_T is access all Integer;

3   Global : Access_T := new Integer'(123);

4

5   function F1 (Param : access Integer) return Boolean is (Param = null);

6   function F2 (Param : access Integer) return Boolean is (F1 (Param));

7

8   function F3 (Param : access Integer) return Boolean is

9     (F1 (Param) -- Param is an anonymous access type

10      or F2 (Global)); -- Global is a named access type

11end Anonymous_Access_Types;

primitives_and_access_type.ads

1package Primitives_And_Access_Type is

2   type Root_T is tagged null record;

3   type Access_Root_T is access all Root_T;

4   function Primitive_Of_Root (V : access Root_T) return Boolean is (V = null);

5   function Action_On_Access (V : Access_Root_T) return Boolean is (V = null);

6   type Child_T is new Root_T with null record;

7   type Access_Child_T is access all Child_T;

8   overriding function Primitive_Of_Root (V : access Child_T) return Boolean is

9     (False);

10   -- Illegal:

11   -- overriding function Action_On_Access (V : access_child_t_t)

12   --                                       return boolean is ( false );

13end Primitives_And_Access_Type;

anonymous_access_modifiers.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Anonymous_Access_Types;

3with Primitives_And_Access_Type;

4procedure Anonymous_Access_Modifiers is

5   Global : aliased Primitives_And_Access_Type.Root_T;

6

7   type Constant_Access_T is access constant Integer;

8   type Not_Null_Access_T is not null access Integer;

9

10   Constant_Access_Object : Constant_Access_T := new Integer'(123);

11   Not_Null_Access_Object : Not_Null_Access_T := new Integer'(345);

12

13begin

14   Put_Line (Boolean'Image (Anonymous_Access_Types.F3 (Not_Null_Access_Object)));

15   Put_Line (Boolean'Image

16        (Primitives_And_Access_Type.Primitive_Of_Root (Global'Access)));

17

18   Put_Line (Integer'Image (Not_Null_Access_Object.all));

19   Not_Null_Access_Object := new Integer'(Constant_Access_Object.all);

20   Put_Line (Integer'Image (Not_Null_Access_Object.all));

21

22   -- Constant_Access_Object.all := Not_Null_Access_Object.all; -- illegal

23   Constant_Access_Object := null; -- legal

24   Put_Line (Boolean'Image (Constant_Access_Object = null));

25end Anonymous_Access_Modifiers;

Footnotes

general.ads

1package General is

2   type Pointed_To_T is new Integer;

3   type Access_T is access all Pointed_To_T;

4   Object : Access_T := new Pointed_To_T;

5

6   type Other_Access_T is access all Pointed_To_T;

7   Other_Object : Other_Access_T := Other_Access_T (Object);

8

9   Pointed_To : aliased Pointed_To_T := 1_234;

10

11end General;

use_general.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with General;     use General;

3procedure Use_General is

4begin

5   Object := Pointed_To'Access;

6   Put_Line (Pointed_To'Image & Pointed_To_T'Image (Object.all));

7   Pointed_To := Pointed_To + 1;

8   Put_Line (Pointed_To'Image & Pointed_To_T'Image (Object.all));

9   Object.all := Object.all * 2;

10   Put_Line (Pointed_To'Image & Pointed_To_T'Image (Object.all));

11end Use_General;

Footnotes

memory_management_types.ads

1with Ada.Unchecked_Deallocation;

2package Memory_Management_Types is

3   type Integer_Access_T is access all Integer;

4   procedure Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access_T);

5end Memory_Management_Types;

memory_management_test.adb

1with Memory_Management_Types; use Memory_Management_Types;

2with Ada.Exceptions;          use Ada.Exceptions;

3with Ada.Text_IO;             use Ada.Text_IO;

4procedure Memory_Management_Test is

5

6   procedure Uninitialized_Pointer is

7      Object : Integer_Access_T;

8   begin

9      Object.all := 123;

10      Put_Line ("Object = " & Integer'Image (Object.all));

11   exception

12      when Err : others =>

13         Put_Line ("Uninitialized_Pointer error: " & Exception_Name (Err));

14   end Uninitialized_Pointer;

15

16   procedure Double_Deallocation is

17      Object : Integer_Access_T;

18   begin

19      Object := new Integer'(123);

20      Put_Line ("Object = " & Integer'Image (Object.all));

21      Free (Object);

22      Free (Object);

23   exception

24      when Err : others =>

25         Put_Line ("Double_Deallocation error: " & Exception_Name (Err));

26   end Double_Deallocation;

27

28   procedure Accessing_Deallocated_Memory is

29      Object : Integer_Access_T;

30   begin

31      Object := new Integer'(123);

32      Put_Line ("Object = " & Integer'Image (Object.all));

33      Free (Object);

34      Put_Line ("Object = " & Integer'Image (Object.all));

35   exception

36      when Err : others =>

37         Put_Line ("Accessing_Deallocated_Memory error: " & Exception_Name (Err));

38   end Accessing_Deallocated_Memory;

39

40   procedure Memory_Leak is

41      Object  : Integer_Access_T;

42   begin

43      for Counter in Integer'Range loop

44         Object  := new Integer'(Counter);

45      end loop;

46      Put_Line ("Complete" );

47   exception

48      when Err : others =>

49         Put_Line ("Memory_Leak error: " & Exception_Name (Err));

50   end Memory_Leak;

51

52begin

53   Uninitialized_Pointer;

54   Double_Deallocation;

55   Accessing_Deallocated_Memory;

56   Memory_Leak;

57end Memory_Management_Test;

Footnotes

pool_specific.ads

1package Pool_Specific is

2   type Pointed_To_T is new Integer;

3   type Access_T is access Pointed_To_T;

4   Object : Access_T := new Pointed_To_T;

5

6   type Other_Access_T is access Pointed_To_T;

7   -- Other_Object : Other_Access_T := Other_Access_T ( Object ); -- illegal

8

9   type String_Access_T is access String;

10end Pool_Specific;

use_pool_specific.adb

1with Ada.Unchecked_Deallocation;

2with Ada.Text_IO;   use Ada.Text_IO;

3with Pool_Specific; use Pool_Specific;

4procedure Use_Pool_Specific is

5   X : Access_T        := new Pointed_To_T'(123);

6   Y : String_Access_T := new String (1 .. 10);

7

8   procedure Free is new Ada.Unchecked_Deallocation (Pointed_To_T, Access_T);

9

10begin

11   Put_Line (Y.all);

12   Y := new String'("String will be long enough to hold this");

13   Put_Line (Y.all);

14   Put_Line (Pointed_To_T'Image (X.all));

15   Free (X);

16   Put_Line (Pointed_To_T'Image (X.all)); -- run-time error

17end Use_Pool_Specific;

Footnotes

generic_data.ads

1package Generic_Data is

2   generic

3      type Discrete_T is (<>);

4      type Integer_T is range <>;

5      type Float_T is digits <>;

6      type Indefinite_T;

7      type Tagged_T is tagged;

8      type Array_T is array (Boolean) of Integer;

9      type Access_T is access all Integer;

10      type Private_T is private;

11      type Unconstrained_T (<>) is private;

12   package Parameter_Properties is

13      procedure Do_Something ( Discrete_Param      : Discrete_T;

14                               Integer_Param       : Integer_T;

15                               Float_Param         : Float_T;

16                               Indefinite_Param    : access Indefinite_T;

17                               Tagged_Param        : Tagged_T;

18                               Array_Param         : Array_T;

19                               Access_Param        : Access_T;

20                               Private_Param       : Private_T;

21                               Unconstrained_Param : Unconstrained_T);

22   end Parameter_Properties;

23

24   generic

25      type Item_T is private;

26      type Access_Item_T is access all Item_T;

27      type Index_T is (<>);

28      type Array_T is array (Index_T range <>) of Access_Item_T;

29   package Combination is

30      procedure Add (List  : in out Array_T;

31                     Index : in     Index_T;

32                     Item  : in     Item_T);

33   end Combination;

34end Generic_Data;

generic_instances.ads

1with Types; use Types;

2with Generic_Data;

3package Generic_Instances is

4   package Parameter_Properties_Instance is new Generic_Data

5     .Parameter_Properties

6     (Boolean, Integer, Float, Indefinite_T => Hidden_T,

7      Tagged_T => Tagged_Record_T, Array_T => Boolean_Array_Of_Integers_T,

8      Access_T => Access_Integer_T, Private_T => Some_Private_T,

9      Unconstrained_T                       => String);

10

11   type Item_T is (Red, White, Blue);

12   type Access_T is access all Item_T;

13   type Index_T is range 1 .. 100;

14   type Array_T is array (Index_T range <>) of Access_T;

15   package Combination_Instance is new Generic_Data.Combination

16     (Item_T, Access_T, Index_T, Array_T);

17end Generic_Instances;

generic_data.adb

1package body Generic_Data is

2   package body Parameter_Properties is

3      procedure Do_Something ( Discrete_Param      : Discrete_T;

4                               Integer_Param       : Integer_T;

5                               Float_Param         : Float_T;

6                               Indefinite_Param    : access Indefinite_T;

7                               Tagged_Param        : Tagged_T;

8                               Array_Param         : Array_T;

9                               Access_Param        : Access_T;

10                               Private_Param       : Private_T;

11                               Unconstrained_Param : Unconstrained_T) is null;

12   end Parameter_Properties;

13

14   package body Combination is

15      procedure Add (List  : in out Array_T;

16                     Index : in     Index_T;

17                     Item  : in     Item_T) is

18      begin

19         List (Index) := new Item_T'(Item);

20      end Add;

21   end Combination;

22end Generic_Data;

types.ads

1package Types is

2   type Hidden_T;

3   type Tagged_Record_T is tagged record

4      Field : access Hidden_T;

5   end record;

6   type Hidden_T is private;

7   type Boolean_Array_Of_Integers_T is array (Boolean) of Integer;

8   type Access_Integer_T is access all Integer;

9   type Some_Private_T is private;

10private

11   type Hidden_T is new Integer;

12   type Some_Private_T is new Integer;

13end Types;

Footnotes

generic_formal_data.ads

1package Generic_Formal_Data is

2   generic

3      type Variable_T is range <>;

4      Variable : in out Variable_T;

5      Increment : Variable_T;

6   package Constants_And_Variables is

7      procedure Add;

8      function Value return Variable_T is (Variable);

9   end Constants_And_Variables;

10

11   generic

12      type Type_T is (<>);

13      with procedure Print_One (Prompt : String; Value : Type_T);

14      with procedure Print_Two (Prompt : String; Value : Type_T) is null;

15      with procedure Print_Three (Prompt : String; Value : Type_T) is <>;

16   package Subprogram_Parameters is

17      procedure Print (Prompt : String; Param : Type_T);

18   end Subprogram_Parameters;

19end Generic_Formal_Data;

test_generic_formal_data.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2with Generic_Formal_Data; use Generic_Formal_Data;

3procedure Test_Generic_Formal_Data is

4   procedure Print_One (Prompt : String; Param : Integer) is

5   begin

6      Put_Line (Prompt & " - Print_One" & Param'Image);

7   end Print_One;

8   procedure Print_Two (Prompt : String; Param : Integer) is

9   begin

10      Put_Line (Prompt & " - Print_Two" & Param'Image);

11   end Print_Two;

12   procedure Print_Three (Prompt : String; Param : Integer) is

13   begin

14      Put_Line (Prompt & " - Print_Three" & Param'Image);

15   end Print_Three;

16   procedure Print_Three_Prime (Prompt : String; Param : Integer) is

17   begin

18      Put_Line (Prompt & " - Print_Three_Prime" & Param'Image);

19   end Print_Three_Prime;

20

21   Global_Object : Integer := 0;

22   package Global_Data is new Constants_And_Variables

23     (Integer, Global_Object, 111);

24

25   package Print_1 is new Subprogram_Parameters (Integer, Print_One);

26   package Print_2 is new Subprogram_Parameters (Integer, Print_One, Print_Two);

27   package Print_3 is new Subprogram_Parameters (Integer, Print_One, Print_Two, Print_Three_Prime);

28

29begin

30   Print_1.Print ("print_1", Global_Data.Value);

31   Global_Data.Add;

32   Print_2.Print ("print_2", Global_Data.Value);

33   Global_Data.Add;

34   Print_3.Print ("print_3", Global_Data.Value);

35end Test_Generic_Formal_Data;

generic_formal_data.adb

1package body Generic_Formal_Data is

2   package body Constants_And_Variables is

3      procedure Add is

4      begin

5         Variable := Variable + Increment;

6      end Add;

7   end Constants_And_Variables;

8

9   package body Subprogram_Parameters is

10      procedure Print (Prompt : String; Param : Type_T) is

11      begin

12         Print_One (Prompt, Param);

13         Print_Two (Prompt, Param);

14         Print_Three (Prompt, Param);

15      end Print;

16   end Subprogram_Parameters;

17end Generic_Formal_Data;

Footnotes

primitives_example.ads

1package Primitives_Example is

2

3   type Record_T is record

4      Field : Integer;

5   end record;

6   type Access_To_Record_T is access Record_T;

7   type Array_T is array (1 .. 10) of Integer;

8

9   procedure Primitive_Of_Record_T (P : in out Record_T) is null;

10   function Primitive_Of_Record_T (P : Integer) return Record_T is

11     ((Field => P));

12   procedure Primitive_Of_Record_T (I : Integer;

13                                    P : access Record_T) is null;

14   procedure Not_A_Primitive_Of_Record_T

15     (I : Integer; P : Access_To_Record_T) is null;

16

17   procedure Primitive_Of_Record_T_And_Array_T

18     (P1 : in out Record_T; P2 : in out Array_T) is null;

19end Primitives_Example;

Footnotes

simple_derivation.ads

1package Simple_Derivation is

2   type Parent_T is range 1 .. 10;

3   function Primitive1 (V : Parent_T) return String is

4     ("Primitive1 of Parent_T" & V'Image);

5   function Primitive2 (V : Parent_T) return String is

6     ("Primitive2 of Parent_T" & V'Image);

7   function Primitive3 (V : Parent_T) return String is

8     ("Primitive3 of Parent_T" & V'Image);

9

10   type Child_T is new Parent_T; -- implicitly gets access to Primitive1

11

12   -- new behavior for Primitive2

13   overriding function Primitive2 (V : Child_T) return String is

14     ("Primitive2 of Child_T" & V'Image);

15

16   -- remove behavior for Primitive3 from Child_T

17   overriding function Primitive3 (V : Child_T) return String is abstract;

18

19   -- add primitive only for Child_T

20   not overriding function Primitive4 (V : Child_T) return String is

21     ("Primitive4 of Child_T" & V'Image);

22end Simple_Derivation;

test_simple_derivation.adb

1with Ada.Text_IO;       use Ada.Text_IO;

2with Simple_Derivation; use Simple_Derivation;

3procedure Test_Simple_Derivation is

4   function Not_A_Primitive (V : Parent_T) return String is

5     ("Not_A_Primitive" & V'Image);

6   Parent_V : Parent_T := 1;

7   Child_V  : Child_T  := 2;

8begin

9   Put_Line ("Parent_V - " & Primitive1 (Parent_V));

10   Put_Line ("Parent_V - " & Primitive2 (Parent_V));

11   Put_Line ("Parent_V - " & Primitive3 (Parent_V));

12   -- Put_Line ("Parent_V - " & Primitive4 (Parent_V)); -- illegal

13

14   Put_Line ("Child_V - " & Primitive1 (Child_V));

15   Put_Line ("Child_V - " & Primitive2 (Child_V));

16   -- Put_Line ("Child_V - " & Primitive3 (Child_V)); -- illegal

17   Put_Line ("Child_V - " & Primitive4 (Child_V));

18

19   Put_Line (Not_A_Primitive (Parent_V));

20   Put_Line (Not_A_Primitive (Parent_T (Child_V)));

21end Test_Simple_Derivation;

Footnotes

tagged_derivation.ads

1package Tagged_Derivation is

2

3   type Root_T is tagged record

4      Root_Field : Integer;

5   end record;

6   function Primitive_1 (This : Root_T) return Integer is (This.Root_Field);

7   function Primitive_2 (This : Root_T) return String is

8     (Integer'Image (This.Root_Field));

9

10   type Child_T is new Root_T with record

11      Child_Field : Integer;

12   end record;

13   overriding function Primitive_2 (This : Child_T) return String is

14     (Integer'Image (This.Root_Field) & " " &

15      Integer'Image (This.Child_Field));

16   function Primitive_3 (This : Child_T) return Integer is

17     (This.Root_Field + This.Child_Field);

18

19   -- type Simple_Deriviation_T is new Child_T; -- illegal

20

21   type Root2_T is tagged record

22      Root_Field : Integer;

23   end record;

24   -- procedure Primitive_4 (X : Root_T; Y : Root2_T); -- illegal

25

26end Tagged_Derivation;

test_tagged_derivation.adb

1with Ada.Text_IO;       use Ada.Text_IO;

2with Tagged_Derivation; use Tagged_Derivation;

3procedure Test_Tagged_Derivation is

4   Root  : Root_T  := (Root_Field => 1);

5   Child : Child_T := (Root_Field => 11, Child_Field => 22);

6begin

7   Put_Line ("Root: " & Primitive_2 (Root));

8   Put_Line ("Child: " & Primitive_2 (Child));

9   Root := Root_T (Child);

10   Put_Line ("Root from Child: " & Primitive_2 (Root));

11   -- Child := Child_T ( Root ); -- illegal

12   -- Put_Line ( "Child from Root: " & Primitive_2 ( Child ) ); -- illegal

13   Child := (Root with Child_Field => 999);

14   Put_Line ("Child from Root via aggregate: " & Primitive_2 (Child));

15end Test_Tagged_Derivation;

Footnotes

class_types.ads

1package Class_Types is

2   type Root_T is tagged null record;

3   type Child1_T is new Root_T with null record;

4   type Child2_T is new Root_T with null record;

5   type Grandchild1_T is new Child1_T with null record;

6

7   -- Root'Class = {Root_T, Child1_T, Child2_T, Grandchild1_T}

8   -- Child1'Class = {Child1_T, Grandchild1_T} Child2'Class = {Child2_T}

9   -- Granchild1'Class ={Grandchild1_T}

10   procedure Test;

11

12end Class_Types;

class_types.adb

1with Ada.Tags;    use Ada.Tags;

2with Ada.Text_IO; use Ada.Text_IO;

3package body Class_Types is

4   Root_Object  : Root_T;

5   Child_Object : Child1_T;

6

7   Class_Object1 : Child1_T'Class := Child_Object;

8   Class_Object2 : Root_T'Class   := Class_Object1;

9   Class_Object3 : Root_T'Class   := Child_Object;

10   -- Class_Object4 : Root_T'class; -- illegal

11

12   procedure Do_Something (Object : in out Root_T'Class) is

13   begin

14      Put_Line

15        ("Do_Something: " & Boolean'Image (Object in Root_T'Class) & " / " &

16         Boolean'Image (Object in Child1_T'Class));

17   end Do_Something;

18

19   procedure Test is

20   begin

21      Put_Line (Boolean'Image (Class_Object1'Tag = Class_Object2'Tag));

22      Put_Line (Boolean'Image (Class_Object2'Tag = Class_Object3'Tag));

23      Do_Something (Root_Object);

24      Do_Something (Child_Object);

25      Do_Something (Class_Object1);

26      Do_Something (Class_Object2);

27      Do_Something (Class_Object3);

28   end Test;

29end Class_Types;

abstract_types.ads

1package Abstract_Types is

2   type Root_T is abstract tagged record

3      Field : Integer;

4   end record;

5   function Primitive1 (V : Root_T) return String is abstract;

6   function Primitive2 (Prompt : String; V : Root_T) return String is

7      (Prompt & "> " & Integer'Image (V.Field));

8

9   type Child_T is abstract new Root_T with null record;

10   -- Child_T does not need to redefine any primitives

11

12   type Grandchild_T is new Child_T with null record;

13   -- Grandchild_T is required to create a concrete version of Primitive2

14   function Primitive1 (V : Grandchild_T) return String is

15     (Integer'Image (V.Field));

16

17   procedure Test;

18end Abstract_Types;

abstract_types.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Abstract_Types is

3   Object1 : constant Grandchild_T := (Field => 123);

4   Object2 : constant Root_T'Class := Object1;

5

6   procedure Test is

7   begin

8      Put_Line (Object1.Primitive1);

9      Put_Line (Primitive2 ("Object1", Object2));

10      Put_Line (Object2.Primitive1);

11      Put_Line (Primitive2 ("Object2", Object2));

12   end Test;

13

14end Abstract_Types;

test.adb

1with Abstract_Types;

2with Class_Types;

3procedure Test is

4begin

5   Class_Types.Test;

6   Abstract_Types.Test;

7end Test;

Footnotes

types.ads

1package Types is

2

3   type Root_T is tagged null record;

4   function Primitive (V : Root_T) return String is ("Root_T");

5

6   type Child_T is new Root_T with null record;

7   function Primitive (V : Child_T) return String is ("Child_T");

8

9end Types;

test_dispatching_and_redispatching.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Types;       use Types;

3procedure Test_Dispatching_And_Redispatching is

4

5   Root_Object  : Root_T;

6   Child_Object : Child_T;

7

8   V1 : constant Root_T'Class  := Root_Object;

9   V2 : constant Root_T'Class  := Child_Object;

10   V3 : constant Child_T'Class := Child_Object;

11

12begin

13

14   Put_Line (Primitive (V1));

15   Put_Line (Primitive (V2));

16   Put_Line (Primitive (V3));

17

18end Test_Dispatching_And_Redispatching;

Footnotes

types.ads

1package Types is

2   type Root_T is tagged record

3      Field : Integer;

4   end record;

5   function Primitive (Left  : Root_T; Right : Root_T) return Integer is

6      (Left.Field + Right.Field);

7   function "=" (Left  : Root_T; Right : Root_T) return Boolean is

8      (Left.Field in Right.Field - 1 .. Right.Field + 1);

9   function Constructor (I : Integer := 0) return Root_T is ((Field => I));

10

11   type Child_T is new Root_T with null record;

12   overriding function Primitive (Left  : Child_T; Right : Child_T) return Integer is

13      (Left.Field * Right.Field);

14   overriding function "=" (Left  : Child_T; Right : Child_T) return Boolean is

15      (Right.Field in Left.Field - 1 .. Left.Field + 1);

16   -- function Constructor ( I : Integer := 0 ) return child_T; -- inherited from Root_t

17

18   type Child2_T is new Root_T with record

19      Field2 : Integer;

20   end record;

21   overriding function Primitive (Left  : Child2_T; Right : Child2_T) return Integer is

22      (Left.Field * Right.Field);

23   overriding function "=" (Left  : Child2_T; Right : Child2_T) return Boolean is

24      (Left.Field = Right.Field);

25   -- must create a constructor because new fields added

26   function Constructor (I : Integer := 0) return Child2_T is ((I, I));

27end Types;

test_exotic_dispatching_operations.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Types;       use Types;

3procedure Test_Exotic_Dispatching_Operations is

4   R1  : constant Root_T       := (Field => 10);

5   R2  : constant Root_T       := (Field => 20);

6   C1  : constant Child_T      := (Field => 10);

7   Cl1 : constant Root_T'Class := R1;

8   Cl2 : constant Root_T'Class := R2;

9   Cl3 : constant Root_T'Class := C1;

10

11   procedure Test_Primitive is

12   begin

13      Put_Line ("Primitive");

14      Put_Line (Integer'Image (Primitive (R1, R2)));                 -- static:  ok

15      -- Put_Line (Integer'Image (Primitive (R1, C1)));              -- static: error

16      Put_Line (Integer'Image (Primitive (Cl1, Cl2)));               -- dynamic: ok

17      -- Put_Line (Integer'Image (Primitive (R1, Cl1)));             -- static: error

18      Put_Line (Integer'Image (Primitive (Root_T'Class (R1), Cl1))); -- dynamic: ok

19      Put_Line (Integer'Image (Primitive (Cl1, Cl3)));               -- dynamic: error

20   end Test_Primitive;

21

22   procedure Test_Equality is

23   begin

24      Put_Line ("Equality");

25      Put_Line ("Cl1 = Cl2 " & Boolean'Image (Cl1 = Cl2));

26      Put_Line ("Cl2 = Cl3 " & Boolean'Image (Cl2 = Cl3));

27      Put_Line ("Cl3 = Cl1 " & Boolean'Image (Cl3 = Cl1));

28   end Test_Equality;

29

30   procedure Test_Constructor is

31      -- Static call to Root_T primitive

32      V1 : Root_T'Class := Root_T'(Constructor);

33      V2 : Root_T'Class := V1;

34      -- Static call to Child2_T primitive

35      V3 : Root_T'Class := Child2_T'(Constructor);

36      -- V4 : Root_T'Class := Constructor; -- What is the tag of V4?

37   begin

38      -- No

39      -- V1 := Constructor;

40

41      -- Yes

42      V1 := Root_T'(Constructor);

43   end Test_Constructor;

44

45begin

46   Test_Equality;

47   Test_Constructor;

48   Test_Primitive;

49end Test_Exotic_Dispatching_Operations;

Footnotes

exception_objects_example.ads

1package Exception_Objects_Example is

2

3   Public_Exception : exception;

4

5   procedure Do_Something (X : Integer);

6

7end Exception_Objects_Example;

exception_objects_example.adb

1package body Exception_Objects_Example is

2   Hidden_Exception : exception;

3

4   procedure Do_Something (X : Integer) is

5   begin

6      if X < 0 then

7         raise Public_Exception;

8      elsif X = 0 then

9         raise Hidden_Exception;

10      end if;

11   end Do_Something;

12

13end Exception_Objects_Example;

test_exception_objects_example.adb

1with Ada.Exceptions;            use Ada.Exceptions;

2with Ada.Text_IO;               use Ada.Text_IO;

3with Exception_Objects_Example; use Exception_Objects_Example;

4procedure Test_Exception_Objects_Example is

5begin

6

7   for I in -1 .. 1 loop

8      begin

9         Put_Line ("Try " & I'Image);

10         Do_Something (I);

11         Put_Line ("   success");

12      exception

13         when Public_Exception =>

14            Put_Line ("   Expected exception");

15         when The_Err : others =>

16            Put_Line ("   Unexpected exception");

17            Put_Line ("      Name: " & Exception_Name (The_Err));

18            Put_Line ("      Information: " & Exception_Information (The_Err));

19            Put_Line ("      Message: " & Exception_Message (The_Err));

20      end;

21   end loop;

22

23end Test_Exception_Objects_Example;

Footnotes

joy_ride.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Automotive;  use Automotive;

3procedure Joy_Ride is

4   Hot_Rod : Vehicle_T;

5   Bored   : Boolean := False;

6begin

7   while not Bored loop

8      Steer_Aimlessly (Bored);

9      Consume_Fuel (Hot_Rod);

10   end loop;

11   Put_Line ("Driving Home");

12   Drive_Home;

13exception

14   when Fuel_Exhausted =>

15      Put_Line ("Pushing Home");

16      Push_Home;

17end Joy_Ride;

automotive.ads

1package Automotive is

2   Fuel_Exhausted : exception;

3

4   type Vehicle_T is record

5      Fuel_Quantity : Float := 10.0;

6      Fuel_Minimum  : Float := 1.0;

7   end record;

8

9   procedure Consume_Fuel (Car : in out Vehicle_T);

10   procedure Steer_Aimlessly (Flag : out Boolean);

11   procedure Drive_Home;

12   procedure Push_Home;

13end Automotive;

automotive.adb

1with GNAT.Random_Numbers; use GNAT.Random_Numbers;

2package body Automotive is

3   Gen : Generator;

4   function Current_Consumption is new Random_Float (Float);

5   function Random_Number is new Random_Discrete (Integer);

6

7   procedure Consume_Fuel (Car : in out Vehicle_T) is

8   begin

9      if Car.Fuel_Quantity <= Car.Fuel_Minimum then

10         raise Fuel_Exhausted;

11      else

12         Car.Fuel_Quantity := Car.Fuel_Quantity - Current_Consumption (Gen);

13      end if;

14   end Consume_Fuel;

15

16   procedure Steer_Aimlessly (Flag : out Boolean) is

17   begin

18      Flag := Random_Number (Gen, 1, 50) = 1;

19      if Random_Number (Gen, 1, 50) = 2 then

20         raise Constraint_Error;

21      end if;

22   end Steer_Aimlessly;

23

24   procedure Drive_Home is null;

25   procedure Push_Home is null;

26

27begin

28   Reset (Gen);

29end Automotive;

Footnotes

implicit_exceptions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Implicit_Exceptions is

3   Array_Object : array (1 .. 100) of Integer;

4

5   procedure Raise_Constraint_Error (X : Integer) is

6   begin

7      Put_Line ("* Raise_Constraint_Error: " & X'Image);

8      Array_Object (X) := X - 10;

9   end Raise_Constraint_Error;

10

11   function Raise_Program_Error (X : Integer) return Boolean is

12   begin

13      Put_Line ("* Raise_Program_Error: " & X'Image);

14      if X in Array_Object'Range then

15         return Array_Object (X) > 0;

16      end if;

17   end Raise_Program_Error;

18end Implicit_Exceptions;

explicit_exceptions.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Explicit_Exceptions is

3   procedure Raise_Storage_Error (X : Integer) is

4   begin

5      Put_Line ("* Raise_Storage_Error: " & X'Image);

6      if X < 0 then

7         raise Storage_Error;

8      end if;

9   end Raise_Storage_Error;

10end Explicit_Exceptions;

test_exceptions.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2with Implicit_Exceptions; use Implicit_Exceptions;

3with Explicit_Exceptions; use Explicit_Exceptions;

4procedure Test_Exceptions is

5   procedure Test_Constraint_Error (X : Integer) is

6   begin

7      Raise_Constraint_Error (X);

8      Put_Line ("Test_Constraint_Error success");

9   exception

10      when Constraint_Error =>

11         Put_Line ("Test_Constraint_Error caught exception");

12   end Test_Constraint_Error;

13

14   procedure Test_Program_Error (X : Integer) is

15   begin

16      if Raise_Program_Error (X) then

17         Put_Line ("Test_Program_Error true");

18      else

19         Put_Line ("Test_Program_Error false");

20      end if;

21   exception

22      when Program_Error =>

23         Put_Line ("Test_Program_Error caught exception");

24   end Test_Program_Error;

25

26   procedure Test_Storage_Error (X : Integer) is

27   begin

28      Raise_Storage_Error (X);

29      Put_Line ("Test_Storage_Error success");

30   exception

31      when Storage_Error =>

32         Put_Line ("Test_Storage_Error caught exception");

33   end Test_Storage_Error;

34

35begin

36   Test_Constraint_Error (20);

37   Test_Constraint_Error (0);

38   Test_Constraint_Error (Integer'Last);

39   Test_Program_Error (Integer'First);

40   Test_Program_Error (Integer'Last);

41   Test_Storage_Error (Integer'First);

42   Test_Storage_Error (Integer'Last);

43end Test_Exceptions;

implicit_exceptions.ads

1package Implicit_Exceptions is

2   procedure Raise_Constraint_Error (X : Integer);

3   function Raise_Program_Error (X : Integer) return Boolean;

4end Implicit_Exceptions;

explicit_exceptions.ads

1package Explicit_Exceptions is

2   procedure Raise_Storage_Error (X : Integer);

3end Explicit_Exceptions;

Footnotes

propagation.adb

1with Ada.Text_IO;         use Ada.Text_IO;

2with GNAT.Random_Numbers; use GNAT.Random_Numbers;

3procedure Propagation is

4   Error1 : exception;

5   Error2 : exception;

6

7   Gen : Generator;

8   procedure Maybe_Raise is

9      Test : constant Float := Random (Gen);

10   begin

11      if Test > 0.666 then

12         raise Error1;

13      end if;

14   exception

15      when Error1 =>

16         if Test > 0.95 then

17            raise Error2;

18         else

19            raise;

20         end if;

21   end Maybe_Raise;

22

23   procedure One is

24   begin

25      Maybe_Raise;

26   end One;

27

28   procedure Two is

29   begin

30      One;

31      Maybe_Raise;

32   exception

33      when Error1 =>

34         Put_Line ("Exception from 1 or 2");

35   end Two;

36

37begin

38   Reset (Gen);

39   Maybe_Raise;

40   Two;

41exception

42   when Error1 =>

43      Put_Line ("Exception from 3");

44end Propagation;

Footnotes

stack.ads

1package Stack is

2   Underflow, Overflow : exception;

3   procedure Push (Item : in Integer);

4   procedure Pop (Item : out Integer);

5end Stack;

stack.adb

1package body Stack is

2   Values : array (1 .. 100) of Integer;

3   Top    : Integer := 0;

4

5   procedure Push (Item : in Integer) is

6   begin

7      if Top = Values'Last then

8         raise Overflow;

9      end if;

10      Top          := Top + 1;

11      Values (Top) := Item;

12   end Push;

13

14   procedure Pop (Item : out Integer) is

15   begin

16      if Top < Values'First then

17         raise Underflow;

18      end if;

19      Item := Values (Top);

20      Top  := Top - 1;

21   end Pop;

22end Stack;

test_stack.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Stack;

3procedure Test_Stack is

4   Global : Integer := 123;

5

6   procedure Push (X : Integer) is

7   begin

8      Stack.Push (X);

9   exception

10      when Stack.Overflow =>

11         Put_Line ("No room on the stack");

12   end Push;

13

14   procedure Pop is

15   begin

16      Stack.Pop (Global);

17   exception

18      when Stack.Underflow =>

19         Put_Line ("Nothing on the stack");

20   end Pop;

21

22begin

23   Pop;

24   for I in 1 .. 100 loop

25      Push (I);

26   end loop;

27   Push (2);

28end Test_Stack;

Footnotes

elab_1.ads

1with Initializer; use Initializer;

2package Elab_1 is

3   Spec_Object : Integer := Call (101);

4   procedure Proc;

5end Elab_1;

elab_1.adb

1package body Elab_1 is

2   Body_Object : Integer := Call (102);

3   procedure Proc is null;

4begin

5   Body_Object := Body_Object + Call (103);

6end Elab_1;

elab_2.ads

1with Initializer; use Initializer;

2package Elab_2 is

3   Spec_Object : Integer := Call (201);

4   procedure Proc;

5end Elab_2;

elab_2.adb

1package body Elab_2 is

2   Body_Object : Integer := Call (202);

3   procedure Proc is null;

4begin

5   Body_Object := Body_Object + Call (203);

6end Elab_2;

test_elab.adb

1with Elab_2;

2with Elab_1;

3procedure Test_Elab is

4begin

5   Elab_2.Proc;

6   Elab_1.Proc;

7end Test_Elab;

initializer.ads

1package Initializer is

2   function Call (I : Integer) return Integer;

3end Initializer;

initializer.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Initializer is

3   function Call (I : Integer) return Integer is

4   begin

5      Put_Line ("Call with " & Integer'Image (I));

6      return I;

7   end Call;

8end Initializer;

Footnotes

pure_p.ads

1package Pure_P is

2   pragma Pure;

3   Some_Constant : constant Integer := Integer'Size;

4   function Call (I : Integer) return Integer is (I);

5end Pure_P;

preelaborate_p.ads

1with Pure_P;

2package Preelaborate_P is

3   pragma Preelaborate;

4   Global_Object : Integer := Pure_P.Some_Constant;

5end Preelaborate_P;

elaborate_body_p.ads

1package Elaborate_Body_P is

2   pragma Elaborate_Body;

3   function Call (I : Integer) return Integer;

4end Elaborate_Body_P;

elaborate_body_p.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Elaborate_Body_P is

3   function Call (I : Integer) return Integer is

4   begin

5      Put_Line ("Call with " & Integer'Image (I));

6      return I;

7   end Call;

8begin

9   Put_Line ("Elaborate_Body_P package execution");

10end Elaborate_Body_P;

elab_1.ads

1with Elaborate_Body_P; use Elaborate_Body_P;

2pragma Elaborate (Elaborate_Body_P);

3package Elab_1 is

4   Spec_Object : Integer := Call (101);

5   procedure Proc;

6end Elab_1;

elab_1.adb

1with Elab_2;

2package body Elab_1 is

3   Body_Object : Integer := Call (102);

4   procedure Proc is null;

5begin

6   Body_Object := Body_Object + Call (103);

7   Elab_2.Proc;

8end Elab_1;

elab_2.ads

1with Elaborate_Body_P; use Elaborate_Body_P;

2package Elab_2 is

3   Spec_Object : Integer := Call (201);

4   procedure Proc;

5end Elab_2;

elab_2.adb

1package body Elab_2 is

2   Body_Object : Integer := Call (202);

3   procedure Proc is null;

4begin

5   Body_Object := Body_Object + Call (203);

6end Elab_2;

test_elab_control.adb

1with Elab_2;

2with Elab_1;

3pragma Elaborate_All (Elab_2);

4procedure Test_Elab_Control is

5begin

6   Elab_1.Proc;

7   Elab_2.Proc;

8end Test_Elab_Control;

Footnotes

stack_pkg.ads

1package Stack_Pkg is

2   procedure Push (Item : in Integer) with

3         Pre  => not Full,

4         Post => not Empty and then Top = Item;

5   procedure Pop (Item : out Integer) with

6         Pre  => not Empty,

7         Post => not Full and Item = Top'Old;

8   function Pop return Integer with

9         Pre  => not Empty,

10         Post => not Full and Pop'Result = Top'Old;

11   function Top return Integer with

12         Pre => not Empty;

13   function Empty return Boolean;

14   function Full return Boolean;

15end Stack_Pkg;

stack_pkg.adb

1package body Stack_Pkg is

2   Values  : array (1 .. 100) of Integer;

3   Current : Natural := 0;

4

5   -- Push/Pop cannot fail because preconditions prevent it

6   procedure Push (Item : in Integer) is

7   begin

8      Current          := Current + 1;

9      Values (Current) := Item;

10   end Push;

11

12   procedure Pop (Item : out Integer) is

13   begin

14      Item    := Values (Current);

15      Current := Current - 1;

16   end Pop;

17

18   function Pop return Integer is

19      Item : constant Integer := Values (Current);

20   begin

21      Current := Current - 1;

22      return Item;

23   end Pop;

24

25   function Top return Integer is (Values (Current));

26   function Empty return Boolean is (Current not in Values'Range);

27   function Full return Boolean is (Current >= Values'Length);

28end Stack_Pkg;

Footnotes

predicates.adb

1with Ada.Exceptions; use Ada.Exceptions;

2with Ada.Text_IO;    use Ada.Text_IO;

3procedure Predicates is

4

5   subtype Even_T is Integer with Dynamic_Predicate => Even_T mod 2 = 0;

6   type Serial_Baud_Rate_T is range 110 .. 115_200 with

7      Static_Predicate => Serial_Baud_Rate_T in -- Non-contiguous range

8          2_400 | 4_800 | 9_600 | 14_400 | 19_200 | 28_800 | 38_400 | 56_000;

9

10   -- This must be dynamic because "others" will be evaluated at run-time

11   subtype Vowel_T is Character with Dynamic_Predicate =>

12         (case Vowel_T is when 'A' | 'E' | 'I' | 'O' | 'U' => True, when others => False);

13

14   type Table_T is array (Integer range <>) of Integer;

15   subtype Sorted_Table_T is Table_T (1 .. 5) with

16        Dynamic_Predicate =>

17        (for all K in Sorted_Table_T'Range =>

18           (K = Sorted_Table_T'First or else Sorted_Table_T (K - 1) <= Sorted_Table_T (K)));

19

20   J      : Even_T;

21   Values : Sorted_Table_T := (1, 3, 5, 7, 9);

22

23begin

24   begin

25      Put_Line ("J is" & J'Img);

26      J := Integer'Succ (J); -- assertion failure here

27      Put_Line ("J is" & J'Img);

28      J := Integer'Succ (J); -- or maybe here

29      Put_Line ("J is" & J'Img);

30   exception

31      when The_Err : others =>

32         Put_Line (Exception_Message (The_Err));

33   end;

34

35   for Baud in Serial_Baud_Rate_T loop

36      Put_Line (Baud'Image);

37   end loop;

38

39   Put_Line (Vowel_T'Image (Vowel_T'Succ ('A')));

40   Put_Line (Vowel_T'Image (Vowel_T'Pred ('Z')));

41

42   begin

43      Values (3) := 0; -- not an exception

44      Values     := (1, 3, 0, 7, 9); -- exception

45   exception

46      when The_Err : others =>

47         Put_Line (Exception_Message (The_Err));

48   end;

49end Predicates;

Footnotes

bank.ads

1package Bank is

2   type Account_T is private with Type_Invariant => Consistent_Balance (Account_T);

3   type Currency_T is delta 0.01 digits 12;

4   function Consistent_Balance (This : Account_T) return Boolean;

5   procedure Open (This : in out Account_T; Initial_Deposit : Currency_T);

6private

7   type List_T is array (1 .. 100) of Currency_T;

8   type Transaction_List_T is record

9      Values : List_T;

10      Count  : Natural := 0;

11   end record;

12   type Account_T is record -- initial state MUST satisfy invariant

13      Current_Balance : Currency_T := 0.0;

14      Withdrawals     : Transaction_List_T;

15      Deposits        : Transaction_List_T;

16   end record;

17end Bank;

bank.adb

1package body Bank is

2   function Total (This : Transaction_List_T) return Currency_T is

3      Result : Currency_T := 0.0;

4   begin

5      for I in 1 .. This.Count loop -- no iteration if list empty

6         Result := Result + This.Values (I);

7      end loop;

8      return Result;

9   end Total;

10   function Consistent_Balance (This : Account_T) return Boolean is

11      ( Total (This.Deposits) - Total (This.Withdrawals) = This.Current_Balance );

12   procedure Open (This : in out Account_T; Initial_Deposit : Currency_T) is

13   begin

14      This.Current_Balance := Initial_Deposit;

15      -- if we checked, the invariant would be false here!

16      This.Withdrawals.Count   := 0;

17      This.Deposits.Count      := 1;

18      This.Deposits.Values (1) := Initial_Deposit;

19   end Open; -- invariant is now true

20end Bank;

Footnotes

test_address_clauses_and_overlays.adb

1with Ada.Text_IO;             use Ada.Text_IO;

2with System;

3with System.Storage_Elements; use System.Storage_Elements;

4procedure Test_Address_Clauses_And_Overlays is

5

6   type Bitfield_T is array (Integer range <>) of Boolean with

7      Pack;

8

9   V : aliased Integer; -- object can be referenced elsewhere

10   pragma Volatile (V);  -- may be updated at any time

11

12   V2 : aliased Integer;

13   pragma Volatile (V2);

14

15   V_A : constant System.Address  := V'Address;

16   V_I : constant Integer_Address := To_Integer (V_A);

17

18   --  This maps directly on to the bits of V

19   V3 : aliased Bitfield_T (1 .. V'Size);

20   for V3'Address use V_A; -- overlays V

21

22   V4 : aliased Integer;

23   --  Trust me, I know what I'm doing, this is V2

24   for V4'Address use To_Address (V_I - 4);

25

26   function Str (Bitfield : Bitfield_T) return String is

27      Retval : String (Bitfield'First .. Bitfield'Last);

28   begin

29      for I in Bitfield'Range loop

30         Retval (I) := (if Bitfield (I) then '1' else '0');

31      end loop;

32      return Retval;

33   end Str;

34

35begin

36

37   V := 123;

38   Put (Integer'Image (V) & " => " & Str (V3));

39   New_Line;

40

41   V3 (V3'First + 2) := not V3 (V3'First + 2);

42   Put (Str (V3) & " => " & Integer'Image (V));

43   New_Line;

44

45   V2 := 456;

46   Put_Line ("V4 = " & Integer'Image (V4));

47   V4 := 789;

48   Put_Line ("V2 = " & Integer'Image (V2));

49

50end Test_Address_Clauses_And_Overlays;

Footnotes

test_data_representation.adb

1with Ada.Text_IO; use Ada.Text_IO;

2procedure Test_Data_Representation is

3

4   type Enum is (E1, E2, E3);

5

6   procedure Attributes is

7      type Integer_T is range 1 .. 10;

8      type Similar_Integer_T is range 1 .. 10 with

9         Size        => 13,

10         Object_Size => 16,

11         Alignment   => 1;

12   begin

13      Put_Line

14        ("Integer_T 'Size / 'Object_size / 'Alignment " &

15         Integer'Image (Integer_T'Size) &

16         Integer'Image (Integer_T'Object_Size) &

17         Integer'Image (Integer_T'Alignment));

18      Put_Line

19        ("Similar_Integer_T 'Size / 'Object_size / 'Alignment " &

20         Integer'Image (Similar_Integer_T'Size) &

21         Integer'Image (Similar_Integer_T'Object_Size) &

22         Integer'Image (Similar_Integer_T'Alignment));

23   end Attributes;

24

25   procedure Representation_Clauses is

26

27      type Normal_Record_T is record

28         A : Integer range 0 .. 4;

29         B : Boolean;

30         C : Integer;

31         D : Enum := E1;

32      end record;

33      type Normal_Array_T is array (1 .. 1_000) of Boolean;

34

35      type Packed_Record_T is record

36         A : Integer range 0 .. 4;

37         B : Boolean;

38         C : Integer;

39         D : Enum := E2;

40      end record with

41         Pack;

42      type Packed_Array_T is array (1 .. 1_000) of Boolean with

43         Pack;

44

45      type Repped_Record_T is record

46         A : Integer range 0 .. 4;

47         B : Boolean;

48         C : Integer;

49         D : Enum := E3;

50      end record;

51      for Repped_Record_T use record

52         A at 0 range 0 ..  2;

53         B at 0 range 3 ..  3;

54         C at 0 range 5 .. 36;

55         D at 5 range 0 ..  2;

56      end record;

57      type Repped_Array_T is array (1 .. 1_000) of Boolean;

58      for Repped_Array_T'Component_Size use 2;

59

60   begin

61      Put_Line

62        ("Size of normal record / array: " &

63         Integer'Image (Normal_Record_T'Size) &

64         Integer'Image (Normal_Array_T'Size));

65      Put_Line

66        ("Size of packed record / array: " &

67         Integer'Image (Packed_Record_T'Size) &

68         Integer'Image (Packed_Array_T'Size));

69      Put_Line

70        ("Size of repped record / array: " &

71         Integer'Image (Repped_Record_T'Size) &

72         Integer'Image (Repped_Array_T'Size));

73   end Representation_Clauses;

74

75begin

76   Attributes;

77   Representation_Clauses;

78

79end Test_Data_Representation;

Footnotes

protected_objects.ads

1package Protected_Objects is

2   protected Object is

3      procedure Set (Prompt : String; V : Integer);

4      function Get (Prompt : String) return Integer;

5   private

6      Local : Integer := 0;

7   end Object;

8end Protected_Objects;

protected_objects.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Protected_Objects is

3   protected body Object is

4      procedure Set (Prompt : String; V : Integer) is

5         Str : constant String := "Set " & Prompt & V'Image;

6      begin

7         Local := V;

8         Put_Line (Str);

9      end Set;

10      function Get (Prompt : String) return Integer is

11         Str : constant String := "Get " & Prompt & Local'Image;

12      begin

13         Put_Line (Str);

14         return Local;

15      end Get;

16   end Object;

17end Protected_Objects;

tasks.ads

1package Tasks is

2   task T1 is

3      entry Start;

4      entry Receive_Message;

5   end T1;

6   task T2 is

7      entry Start;

8      entry Receive_Message;

9   end T2;

10end Tasks;

test_protected_objects.adb

1with Tasks; use Tasks;

2procedure Test_Protected_Objects is

3begin

4   T1.Start;

5   T1.Receive_Message;

6   T2.Start;

7   T2.Receive_Message;

8   T2.Receive_Message;

9   T1.Receive_Message;

10end Test_Protected_Objects;

tasks.adb

1with Protected_Objects; use Protected_Objects;

2package body Tasks is

3   task body T1 is

4   begin

5      accept Start do

6         Object.Set ("T1 Start", 0);

7      end Start;

8      loop

9         accept Receive_Message do

10            Object.Set ("T1 Receive", Object.Get ("T1 Receive") + 1);

11         end Receive_Message;

12      end loop;

13   end T1;

14

15   task body T2 is

16   begin

17      accept Start do

18         Object.Set ("T2 Start", 0);

19      end Start;

20      loop

21         accept Receive_Message do

22            Object.Set ("T2 Receive", Object.Get ("T2 Receive") + 1);

23         end Receive_Message;

24      end loop;

25   end T2;

26end Tasks;

Footnotes

some_advanced_concepts.ads

1package Some_Advanced_Concepts is

2   Termination_Flag : Boolean := False;

3   task Select_Loop_Task is

4      entry Start;

5      entry Receive_Message (V : String);

6      entry Send_Message (V : String);

7      entry Stop;

8   end Select_Loop_Task;

9end Some_Advanced_Concepts;

some_advanced_concepts.adb

1with Ada.Calendar; use Ada.Calendar;

2with Ada.Text_IO;  use Ada.Text_IO;

3package body Some_Advanced_Concepts is

4   task body Select_Loop_Task is

5   begin

6      accept Start do

7         Put_Line ("Select_Loop_Task started at" &

8                   Day_Duration'Image (Seconds (Clock)));

9      end Start;

10      loop

11         select

12            accept Receive_Message (V : String) do

13               Put_Line ("Select_Loop_Task Receive: " & V);

14            end Receive_Message;

15         or

16            accept Send_Message (V : String) do

17               Put_Line ("Select_Loop_Task Send: " & V);

18            end Send_Message;

19         or when Termination_Flag =>

20            accept Stop;

21         or

22            delay 5.0;

23            Put_Line ("No more waiting at" & Day_Duration'Image (Seconds (Clock)));

24            exit;

25         end select;

26      end loop;

27   end Select_Loop_Task;

28

29end Some_Advanced_Concepts;

test_some_advanced_concepts.adb

1with Ada.Text_IO;            use Ada.Text_IO;

2with Some_Advanced_Concepts; use Some_Advanced_Concepts;

3procedure Test_Some_Advanced_Concepts is

4begin

5   Put_Line ("calling start");

6   Select_Loop_Task.Start;

7   Select_Loop_Task.Receive_Message ("1");

8   Select_Loop_Task.Send_Message ("A");

9   Select_Loop_Task.Send_Message ("B");

10   Select_Loop_Task.Receive_Message ("2");

11   Select_Loop_Task.Stop;

12exception

13   when Tasking_Error =>

14      Put_Line ("Expected exception: Entry not reached");

15end Test_Some_Advanced_Concepts;

Footnotes

tasks.ads

1package Tasks is

2   task type T is

3      entry Start (Id : Character; Initial_1, Initial_2 : Integer);

4      entry Receive_Message (Delta_1, Delta_2 : Integer);

5   end T;

6   T1, T2 : T;

7end Tasks;

protected_objects.ads

1package Protected_Objects is

2   protected type Object is

3      procedure Set (Caller : Character; V : Integer);

4      function Get return Integer;

5      procedure Initialize (My_Id : Character);

6   private

7      Local : Integer   := 0;

8      Id    : Character := ' ';

9   end Object;

10   O1, O2 : Object;

11end Protected_Objects;

test_types.adb

1with Tasks;             use Tasks;

2with Protected_Objects; use Protected_Objects;

3procedure Test_Types is

4begin

5   O1.Initialize ('X');

6   O2.Initialize ('Y');

7   T1.Start ('A', 1, 2);

8   T2.Start ('B', 1_000, 2_000);

9   T1.Receive_Message (1, 2);

10   T2.Receive_Message (10, 20);

11end Test_Types;

tasks.adb

1with Protected_Objects; use Protected_Objects;

2package body Tasks is

3   task body T is

4      My_Id : Character := ' ';

5   begin

6      accept Start (Id : Character; Initial_1, Initial_2 : Integer) do

7         My_Id := Id;

8         O1.Set (My_Id, Initial_1);

9         O2.Set (My_Id, Initial_2);

10      end Start;

11      loop

12         accept Receive_Message (Delta_1, Delta_2 : Integer) do

13            declare

14               New_1 : constant Integer := O1.Get + Delta_1;

15               New_2 : constant Integer := O2.Get + Delta_2;

16            begin

17               O1.Set (My_Id, New_1);

18               O2.Set (My_Id, New_2);

19            end;

20         end Receive_Message;

21      end loop;

22   end T;

23end Tasks;

protected_objects.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Protected_Objects is

3   protected body Object is

4      procedure Initialize (My_Id : Character) is

5      begin

6         Id := My_Id;

7      end Initialize;

8      procedure Set (Caller : Character; V : Integer) is

9      begin

10         Local := V;

11         Put_Line ( "Task-" & Caller & " Object-" & Id & " => " & V'Image );

12      end Set;

13      function Get return Integer is

14      begin

15         return Local;

16      end Get;

17   end Object;

18end Protected_Objects;

Footnotes

tasks.ads

1package Tasks is

2   task T is

3      entry Start;

4      entry Receive_Message (V : String);

5   end T;

6end Tasks;

tasks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2package body Tasks is

3   task body T is

4   begin

5      loop

6         accept Start do

7            Put_Line ("Start");

8         end Start;

9         accept Receive_Message (V : String) do

10            Put_Line ("Receive " & V);

11         end Receive_Message;

12      end loop;

13   end T;

14end Tasks;

test_tasks.adb

1with Ada.Text_IO; use Ada.Text_IO;

2with Tasks;       use Tasks;

3procedure Test_Tasks is

4begin

5   Put_Line ("calling start");

6   T.Start;

7   Put_Line ("calling receive 1");

8   T.Receive_Message ("1");

9   Put_Line ("calling receive 2");

10   --  Locks until somebody calls Start

11   T.Receive_Message ("2");

12end Test_Tasks;

Footnotes