Previous
Contents
Next
This appendix gives the final versions of the packages developed in this book. There are minor differences between the forms of the packages shown here and those in the main text; apart from some changes in layout, all with clauses are now shown in full and use and use type clauses are sometimes placed differently. In some cases, use clauses that were assumed for the sake of clarity of exposition in the main text are omitted in favour of fully qualified names. These changes do not affect the meaning or the behaviour of the code.
(See chapter 4)
package JE is
-- an empty package!
end JE;
with JE.Times;
use JE.Times;
package JE.Appointments is
type Appointment_Type is abstract tagged private;
function Date (Appt : Appointment_Type) return Time_Type;
function Details (Appt : Appointment_Type) return String;
procedure Appointment (Date : in Time_Type;
Details : in String;
Result : out Appointment_Type);
procedure Put (Appt : in Appointment_Type) is abstract;
private
type Appointment_Type is
abstract tagged record
Time : Time_Type;
Details : String (1..50);
Length : Natural := 0;
end record;
end JE.Appointments;
----------------- Package body -----------------
package body JE.Appointments is
function Date (Appt : Appointment_Type) return Time_Type is
begin
return Appt.Time;
end Date;
function Details (Appt : Appointment_Type) return String is
begin
return Appt.Details (1..Appt.Length);
end Details;
procedure Appointment (Date : in Time_Type;
Details : in String;
Result : out Appointment_Type) is
begin
Result.Time := Date;
if Details'Length > Result.Details'Length then
Result.Details :=
Details(Details'First ..
Details'First+Result.Details'Length-1);
Result.Length := Result.Details'Length;
else
Result.Details(1..Details'Length) := Details;
Result.Length := Details'Length;
end if;
end Appointment;
end JE.Appointments;
package JE.Appointments.Meetings is
subtype Room_Type is Integer range 100 .. 999;
type Meeting_Type is abstract new Appointment_Type with private;
procedure Meeting (Date : in Time_Type;
Details : in String;
Room : in Room_Type;
Result : out Meeting_Type);
function Room (Appt : Meeting_Type) return Room_Type;
-- Date, Details and Put inherited unchanged from Appointment_Type;
-- so is Appointment, but don't use it!
private
type Meeting_Type is abstract new Appointment_Type with
record
Room : Room_Type;
end record;
end JE.Appointments.Meetings;
----------------- Package body -----------------
package body JE.Appointments.Meetings is
procedure Meeting (Date : in Time_Type;
Details : in String;
Room : in Room_Type;
Result : out Meeting_Type) is
begin
Appointment (Date, Details, Result);
Result.Room := Room;
end Meeting;
function Room (Appt : Meeting_Type) return Room_Type is
begin
return Appt.Room;
end Room;
end JE.Appointments.Meetings;
(See chapter 15)
package JE.Appointments.Deadlines is
type Deadline_Type is
abstract new Appointment_Type with null record;
procedure Put (Appt : in Deadline_Type) is abstract;
-- Date, Details and Appointment inherited unchanged
-- from Appointment_Type
end JE.Appointments.Deadlines;
(See chapters 10, 11, 12 and 15)
with JE.Appointments, JE.Lists;
use JE.Appointments;
package JE.Diaries is
type Diary_Type is limited private;
procedure Load (Diary : in out Diary_Type;
From : in String);
procedure Save (Diary : in Diary_Type;
To : in String);
procedure Add (Diary : in out Diary_Type;
Appt : in Appointment_Type'Class);
function Choose (Diary : Diary_Type;
Appt : Positive) return Appointment_Type'Class;
procedure Delete (Diary : in out Diary_Type;
Appt : in Positive);
function Size (Diary : Diary_Type) return Natural;
Diary_Error : exception;
private
type Appointment_Access is access Appointment_Type'Class;
package Lists is new JE.Lists (Item_Type => Appointment_Access);
type Diary_Type is
limited record
List : Lists.List_Type;
end record;
end JE.Diaries;
----------------- Package body -----------------
with Ada.Streams.Stream_IO, JE.Times;
package body JE.Diaries is
use type JE.Times.Time_Type; -- to allow use of ">"
use type Lists.List_Iterator; -- to allow use of "/="
function Size (Diary : Diary_Type) return Natural is
begin
return Lists.Size(Diary.List);
end Size;
function Choose (Diary : Diary_Type;
Appt : Positive) return Appointment_Type'Class is
Iterator : Lists.List_Iterator;
begin
if Appt not in 1 .. Lists.Size(Diary.List) then
raise Diary_Error;
else
Iterator := Lists.First(Diary.List);
for I in 2 .. Appt loop
Iterator := Lists.Succ(Iterator);
end loop;
return Lists.Value(Iterator).all;
end if;
end Choose;
procedure Delete (Diary : in out Diary_Type;
Appt : in Positive) is
Iterator : Lists.List_Iterator;
begin
if Appt not in 1 .. Lists.Size(Diary.List) then
raise Diary_Error;
else
Iterator := Lists.First(Diary.List);
for I in 2 .. Appt loop
Iterator := Lists.Succ(Iterator);
end loop;
Lists.Delete (Iterator);
end if;
end Delete;
procedure Add (Diary : in out Diary_Type;
Appt : in Appointment_Type'Class) is
Iterator : Lists.List_Iterator;
begin
Iterator := Lists.First(Diary.List);
while Iterator /= Lists.Last(Diary.List) loop
exit when Date(Lists.Value(Iterator).all) > Date(Appt);
Iterator := Lists.Succ(Iterator);
end loop;
Lists.Insert (Iterator, new Appointment_Type'Class'(Appt));
exception
when Storage_Error =>
raise Diary_Error;
end Add;
procedure Save (Diary : in Diary_Type;
To : in String) is
File : Ada.Streams.Stream_IO.File_Type;
Stream : Ada.Streams.Stream_IO.Stream_Access;
I : Lists.List_Iterator := Lists.First(Diary.List);
begin
Ada.Streams.Stream_IO.Create (File, Name => To);
Stream := Ada.Streams.Stream_IO.Stream(File);
while I /= Lists.Last(Diary.List) loop
Appointment_Type'Class'Output (Stream, Lists.Value(I).all);
I := Lists.Succ(I);
end loop;
Ada.Streams.Stream_IO.Close (File);
end Save;
procedure Load (Diary : in out JE.Diaries.Diary_Type;
From : in String) is
File : Ada.Streams.Stream_IO.File_Type;
Stream : Ada.Streams.Stream_IO.Stream_Access;
begin
while Size(Diary) > 0 loop
Lists.Delete (Lists.First(Diary.List));
end loop;
Ada.Streams.Stream_IO.Open (File, Name => From,
Mode => Ada.Streams.Stream_IO.In_File);
Stream := Ada.Streams.Stream_IO.Stream(File);
while not Ada.Streams.Stream_IO.End_Of_File(File) loop
Add (Diary, Appointment_Type'Class'Input (Stream));
end loop;
Ada.Streams.Stream_IO.Close (File);
exception
when Ada.Streams.Stream_IO.Name_Error =>
raise Diary_Error;
end Load;
end JE.Diaries;
(See chapter 17)
with JE.Pointers;
package JE.Expressions is
type Expression_Type is tagged limited private;
function Evaluate (Syntax : Expression_Type;
Expr : String) return Integer;
Syntax_Error : exception;
private
type Priority_Type is range 0..9;
subtype Operator_Priority_Type
is Priority_Type range 1..Priority_Type'Last;
type Expression_Type is tagged limited null record;
type Token_Type is abstract tagged null record;
type Token_Access is access Token_Type'Class;
package Token_Pointers is new JE.Pointers (Token_Type'Class,
Token_Access);
subtype Token_Pointer is Token_Pointers.Pointer_Type;
procedure Next_Token (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Token : in out Token_Pointer);
procedure Fetch_Token (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Token : in out Token_Pointer);
procedure Parse (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Prio : in Priority_Type;
Result : out Integer;
Next : in out Token_Pointer);
procedure Get_Operand (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Result : out Integer;
Next : in out Token_Pointer);
type Left_Parenthesis is new Token_Type with null record;
type Right_Parenthesis is new Token_Type with null record;
type End_Of_Expression is new Token_Type with null record;
type Operand_Type is abstract new Token_Type with null record;
function Value (Operand : Operand_Type) return Integer is abstract;
type Number_Type (Value : Integer) is new Operand_Type
with null record;
function Value (Operand : Number_Type) return Integer;
type Operator_Type is abstract new Token_Type with null record;
function Priority (Operator : Operator_Type)
return Operator_Priority_Type is abstract;
type Unary_Operator_Type is abstract new Operator_Type
with null record;
function Apply (Operator : Unary_Operator_Type;
Right : Integer) return Integer is abstract;
type Binary_Operator_Type is abstract new Operator_Type
with null record;
function Apply (Operator : Binary_Operator_Type;
Left, Right : Integer) return Integer is abstract;
type Variadic_Operator_Type is abstract new Binary_Operator_Type
with null record;
function Apply (Operator : Variadic_Operator_Type;
Right : Integer) return Integer is abstract;
type Multiplying_Operator_Type is abstract new Binary_Operator_Type
with null record;
function Priority (Operator : Multiplying_Operator_Type)
return Operator_Priority_Type;
type Adding_Operator_Type is abstract new Variadic_Operator_Type
with null record;
function Priority (Operator : Adding_Operator_Type)
return Operator_Priority_Type;
function Unary_Priority (Operator : Adding_Operator_Type)
return Operator_Priority_Type;
type Times_Operator is new Multiplying_Operator_Type with null record;
function Apply (Operator : Times_Operator;
Left, Right : Integer) return Integer;
type Over_Operator is new Multiplying_Operator_Type with null record;
function Apply (Operator : Over_Operator;
Left, Right : Integer) return Integer;
type Plus_Operator is new Adding_Operator_Type with null record;
function Apply (Operator : Plus_Operator;
Left, Right : Integer) return Integer;
function Apply (Operator : Plus_Operator;
Right : Integer) return Integer;
type Minus_Operator is new Adding_Operator_Type with null record;
function Apply (Operator : Minus_Operator;
Left, Right : Integer) return Integer;
function Apply (Operator : Minus_Operator;
Right : Integer) return Integer;
end JE.Expressions;
----------------- Package body -----------------
with Ada.Exceptions, Ada.Integer_Text_IO;
package body JE.Expressions is
use Token_Pointers;
function Evaluate (Syntax : Expression_Type;
Expr : String) return Integer is
Token : Token_Pointer;
From : Positive := Expr'First;
Result : Integer;
begin
Parse (Expression_Type'Class(Syntax), Expr, From,
Priority_Type'Last, Result, Token);
if Value(Token).all not in End_Of_Expression'Class then
Ada.Exceptions.Raise_Exception (Syntax_Error'Identity,
"Missing operator or left parenthesis");
end if;
return Result;
end Evaluate;
function Priority (Operator : Multiplying_Operator_Type)
return Operator_Priority_Type is
begin
return 5;
end Priority;
function Priority (Operator : Adding_Operator_Type)
return Operator_Priority_Type is
begin
return 6;
end Priority;
function Unary_Priority (Operator : Adding_Operator_Type)
return Operator_Priority_Type is
begin
return 2;
end Unary_Priority;
function Apply (Operator : Times_Operator;
Left, Right : Integer) return Integer is
begin
return Left * Right;
end Apply;
function Apply (Operator : Over_Operator;
Left, Right : Integer) return Integer is
begin
return Left / Right;
end Apply;
function Apply (Operator : Plus_Operator;
Left, Right : Integer) return Integer is
begin
return Left + Right;
end Apply;
function Apply (Operator : Plus_Operator;
Right : Integer) return Integer is
begin
return Right;
end Apply;
function Apply (Operator : Minus_Operator;
Left, Right : Integer) return Integer is
begin
return Left - Right;
end Apply;
function Apply (Operator : Minus_Operator;
Right : Integer) return Integer is
begin
return -Right;
end Apply;
function Value (Operand : Number_Type) return Integer is
begin
return Operand.Value;
end Value;
procedure Next_Token (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Token : in out Token_Pointer) is
begin
-- Find start of next token
while From <= Expr'Last and then Expr(From) = ' ' loop
From := From + 1;
end loop;
-- Check for end of expression
if From > Expr'Last then
Token := Pointer(new End_Of_Expression);
else
Fetch_Token (Expression_Type'Class(Syntax), Expr, From, Token);
end if;
end Next_Token;
procedure Fetch_Token (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Token : in out Token_Pointer) is
begin
case Expr(From) is
when '+' =>
Token := Pointer(new Plus_Operator);
when '-' =>
Token := Pointer(new Minus_Operator);
when '*' =>
Token := Pointer(new Times_Operator);
when '/' =>
Token := Pointer(new Over_Operator);
when '(' =>
Token := Pointer(new Left_Parenthesis);
when ')' =>
Token := Pointer(new Right_Parenthesis);
when '0'..'9' =>
declare
Value : Integer;
begin
Ada.Integer_Text_IO.Get (Expr(From..Expr'Last),
Value, From);
Token := Pointer(new Number_Type(Value));
end;
when others =>
Ada.Exceptions.Raise_Exception (Syntax_Error'Identity,
"Illegal character '" & Expr(From) & "'");
end case;
From := From + 1;
end Fetch_Token;
procedure Parse (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Prio : in Priority_Type;
Result : out Integer;
Next : in out Token_Pointer) is
begin
if Prio = Priority_Type'First then
Get_Operand (Expression_Type'Class(Syntax),
Expr, From, Result, Next);
else
declare
Right : Integer;
Op : Token_Pointer;
begin
Parse (Syntax, Expr, From, Prio-1, Result, Op);
while Value(Op).all in Binary_Operator_Type'Class and then
Priority(Binary_Operator_Type'Class(Value(Op).all)) =
Prio
loop
Parse (Syntax, Expr, From, Prio-1, Right, Next);
Result := Apply (Binary_Operator_Type'Class(Value(Op).all),
Result, Right);
Op := Next;
end loop;
Next := Op;
end;
end if;
end Parse;
procedure Get_Operand (Syntax : in Expression_Type;
Expr : in String;
From : in out Positive;
Result : out Integer;
Next : in out Token_Pointer) is
Op : Token_Pointer;
begin
Next_Token (Expression_Type'Class(Syntax), Expr, From, Next);
if Value(Next).all in Operand_Type'Class then
Result := Value (Operand_Type'Class(Value(Next).all));
Next_Token (Expression_Type'Class(Syntax), Expr, From, Next);
elsif Value(Next).all in Left_Parenthesis'Class then
Parse (Expression_Type'Class(Syntax),
Expr, From, Priority_Type'Last, Result, Next);
if Value(Next).all in Right_Parenthesis'Class then
Next_Token (Expression_Type'Class(Syntax), Expr, From,
Next);
else
Ada.Exceptions.Raise_Exception (Syntax_Error'Identity,
"Missing right parenthesis");
end if;
elsif Value(Next).all in Unary_Operator_Type'Class then
Op := Next;
Parse (Expression_Type'Class(Syntax), Expr, From,
Priority (Unary_Operator_Type'Class(Value(Op).all)),
Result, Next);
Result := Apply (Unary_Operator_Type'Class(Value(Op).all),
Result);
elsif Value(Next).all in Variadic_Operator_Type'Class then
Op := Next;
Parse (Expression_Type'Class(Syntax), Expr, From,
Priority (Variadic_Operator_Type'Class(Value(Op).all)),
Result, Next);
Result := Apply (Variadic_Operator_Type'Class(Value(Op).all),
Result);
elsif Value(Next).all in End_Of_Expression'Class then
Ada.Exceptions.Raise_Exception (Syntax_Error'Identity,
"Expression incomplete");
else
Ada.Exceptions.Raise_Exception (Syntax_Error'Identity,
"Illegal token");
end if;
end Get_Operand;
end JE.Expressions;
(See chapter 18)
with JE.Spreadsheets;
use JE.Spreadsheets;
package JE.Expressions.Spreadsheet is
type Formula_Type (Sheet : access Spreadsheet_Type'Class) is
new Expression_Type with private;
private
type Cell_Operand_Type (Cell : Cell_Access) is new Operand_Type
with null record;
function Value (Operand : Cell_Operand_Type) return Integer;
type Formula_Type (Sheet : access Spreadsheet_Type'Class) is
new Expression_Type with null
record;
procedure Fetch_Token (Syntax : in Formula_Type;
Expr : in String;
From : in out Positive;
Token : in out Token_Pointer);
end JE.Expressions.Spreadsheet;
----------------- Package body -----------------
with JE.Spreadsheets; use JE.Spreadsheets;
package body JE.Expressions.Spreadsheet is
use JE.Expressions.Token_Pointers;
function Value (Operand : Cell_Operand_Type) return Integer is
begin
if Operand.Cell = null then
raise Undefined_Cell_Error;
else
Evaluate (Operand.Cell.all);
end if;
return Num_Value (Operand.Cell.all);
end Value;
procedure Fetch_Token (Syntax : in Formula_Type;
Expr : in String;
From : in out Positive;
Token : in out Token_Pointer) is
begin
case Expr(From) is
when 'A'..'Z' | 'a'..'z' =>
declare
First : Integer := From;
Cell_Ptr : Cell_Access;
begin
while (From <= Expr'Length) and then
(Expr(From) in 'A'..'Z' or
Expr(From) in 'a'..'z' or
Expr(From) in '0'..'9')
loop
From := From + 1;
end loop;
Cell_Ptr := Cell (Syntax.Sheet.all, Expr(First..From-1));
Token := Pointer(new Cell_Operand_Type(Cell_Ptr));
end;
when others =>
Fetch_Token(Expression_Type(Syntax), Expr, From, Token);
end case;
end Fetch_Token;
end JE.Expressions.Spreadsheet;
with Ada.Finalization;
use Ada.Finalization;
generic
type Item_Type is private;
package JE.Lists is
type List_Type is new Limited_Controlled with private;
type List_Iterator is private;
function Size (List : List_Type) return Natural;
function First (List : List_Type) return List_Iterator;
function Last (List : List_Type) return List_Iterator;
function Succ (Iterator : List_Iterator) return List_Iterator;
function Pred (Iterator : List_Iterator) return List_Iterator;
function Value (Iterator : List_Iterator) return Item_Type;
procedure Insert (Iterator : in List_Iterator;
Item : in Item_Type);
procedure Delete (Iterator : in List_Iterator);
List_Error : exception;
private
type Item_Record;
type Item_Access is access Item_Record;
type Item_Record is
record
Item : Item_Type;
Next : Item_Access;
Pred : Item_Access;
end record;
type List_Header is
record
First : Item_Access;
Last : Item_Access;
Count : Natural := 0;
end record;
type List_Access is access List_Header;
type List_Type is new Limited_Controlled with
record
List : List_Access := new List_Header;
end record;
procedure Finalize (Object : in out List_Type);
type List_Iterator is
record
List : List_Access;
Current : Item_Access;
end record;
end JE.Lists;
----------------- Package body -----------------
with Ada.Unchecked_Deallocation;
package body JE.Lists is
procedure Delete_Item is new Ada.Unchecked_Deallocation
(Item_Record, Item_Access);
function Size (List : List_Type) return Natural is
begin
return List.List.Count;
end Size;
function First (List : List_Type) return List_Iterator is
begin
return (List => List.List, Current => List.List.First);
end First;
function Last (List : List_Type) return List_Iterator is
begin
return (List => List.List, Current => null);
end Last;
function Succ (Iterator : List_Iterator) return List_Iterator is
begin
if Iterator.List = null or else Iterator.Current = null then
raise List_Error;
else
return (List => Iterator.List, Current => Iterator.Current.Next);
end if;
end Succ;
function Pred (Iterator : List_Iterator) return List_Iterator is
begin
if Iterator.List = null or else
Iterator.Current = Iterator.List.First then
raise List_Error;
elsif Iterator.Current = null then
return (List => Iterator.List, Current => Iterator.List.Last);
else
return (List => Iterator.List, Current => Iterator.Current.Pred);
end if;
end Pred;
function Value (Iterator : List_Iterator) return Item_Type is
begin
if Iterator.List = null or else Iterator.Current = null then
raise List_Error;
else
return Iterator.Current.Item;
end if;
end Value;
procedure Delete (Iterator : in List_Iterator) is
Item : Item_Access := Iterator.Current;
begin
if Iterator.List = null or else Iterator.Current = null then
raise List_Error;
else
if Iterator.Current.Next = null then
Iterator.List.Last := Iterator.Current.Pred;
else
Iterator.Current.Next.Pred := Iterator.Current.Pred;
end if;
if Iterator.Current.Pred = null then
Iterator.List.First := Iterator.Current.Next;
else
Iterator.Current.Pred.Next := Iterator.Current.Next;
end if;
Delete_Item (Item);
Iterator.List.Count := Iterator.List.Count - 1;
end if;
end Delete;
procedure Insert (Iterator : in List_Iterator;
Item : in Item_Type) is
New_Item : Item_Access;
begin
if Iterator.List = null then
raise List_Error;
else
New_Item := new Item_Record;
New_Item.Next := Iterator.Current;
New_Item.Item := Item;
if Iterator.Current = null then
New_Item.Pred := Iterator.List.Last;
Iterator.List.Last := New_Item;
else
New_Item.Pred := Iterator.Current.Pred;
Iterator.Current.Pred := New_Item;
end if;
if Iterator.Current = Iterator.List.First then
Iterator.List.First := New_Item;
else
New_Item.Pred.Next := New_Item;
end if;
Iterator.List.Count := Iterator.List.Count + 1;
end if;
end Insert;
procedure Finalize (Object : in out List_Type) is
procedure Delete_Header is
new Ada.Unchecked_Deallocation (List_Header, List_Access);
begin
while First(Object) /= Last(Object) loop
Delete (First(Object));
end loop;
Delete_Header (Object.List);
end Finalize;
end JE.Lists;
(See chapter 12)
with JE.Lists;
generic
package JE.Menus is
type Action_Type is access procedure;
type Menu_Type is limited private;
procedure Add (Menu : in out Menu_Type;
Title : in String;
Key : in Character;
Action : in Action_Type);
function Execute (Menu : Menu_Type) return Boolean;
private
type Menu_Item_Type is
record
Title : String (1..40);
Length : Natural;
Choice : Character;
Action : Action_Type;
end record;
package Menu_Lists is new JE.Lists (Menu_Item_Type);
type Menu_Type is
limited record
Menu_List : Menu_Lists.List_Type;
end record;
end JE.Menus;
----------------- Package body -----------------
with Ada.Text_IO, Ada.Characters.Handling;
use Ada.Text_IO;
package body JE.Menus is
procedure Add (Menu : in out Menu_Type;
Title : in String;
Key : in Character;
Action : in Action_Type) is
Item : Menu_Item_Type;
use Menu_Lists;
begin
if Title'Length > Item.Title'Length then
Item.Title :=
Title (Title'First .. Item.Title'Length-Title'First+1);
Item.Length := Item.Title'Length;
else
Item.Title (Item.Title'First .. Title'Length-Item.Title'First+1)
:= Title;
Item.Length := Title'Length;
end if;
Item.Choice := Ada.Characters.Handling.To_Upper(Key);
Item.Action := Action;
Insert( Last(Menu.Menu_List), Item );
end Add;
function Execute (Menu : Menu_Type) return Boolean is
Item : Menu_Item_Type;
Choice : Character;
use Menu_Lists;
I : List_Iterator;
begin
loop
New_Line (3);
-- Display the menu
I := First(Menu.Menu_List);
while I /= Last(Menu.Menu_List) loop
Item := Value(I);
Put (" [");
Put (Item.Choice);
Put ("] ");
Put_Line (Item.Title(1..Item.Length));
I := Succ(I);
end loop;
-- Display the Quit option and prompt
Put_Line (" [Q] Quit");
Put ("Enter your choice: ");
-- Get user's choice in upper case
Get (Choice);
Choice := Ada.Characters.Handling.To_Upper(Choice);
if Choice = 'Q' then
-- Quit chosen, so return
return False;
else
-- Search menu for choice
I := First(Menu.Menu_List);
while I /= Last(Menu.Menu_List) loop
if Choice = Value(I).Choice then
-- Choice found, so call procedure and return
Value(I).Action.all;
return True;
end if;
I := Succ(I);
end loop;
end if;
-- Choice wasn't found, so display error message and loop
Put_Line ("Invalid choice -- please try again.");
end loop;
end Execute;
end JE.Menus;
(See chapter 16)
with Ada.Finalization;
generic
type Item_Type(<>) is limited private;
type Access_Type is access Item_Type;
package JE.Pointers is
type Pointer_Type is private;
function Pointer (Value : Access_Type) return Pointer_Type;
function Value (Pointer : Pointer_Type) return Access_Type;
private
type Reference_Counted_Object is
record
Value : Access_Type;
Count : Natural;
end record;
type Reference_Counted_Pointer is access Reference_Counted_Object;
type Pointer_Type is new Ada.Finalization.Controlled with
record
Pointer : Reference_Counted_Pointer;
end record;
procedure Finalize (Object : in out Pointer_Type);
procedure Adjust (Object : in out Pointer_Type);
end JE.Pointers;
----------------- Package body -----------------
with Ada.Unchecked_Deallocation;
package body JE.Pointers is
procedure Delete_Item is
new Ada.Unchecked_Deallocation (Item_Type, Access_Type);
procedure Delete_Pointer is
new Ada.Unchecked_Deallocation (Reference_Counted_Object,
Reference_Counted_Pointer);
function Pointer (Value : Access_Type) return Pointer_Type is
Object : Pointer_Type;
begin
if Object.Pointer /= null then
Delete_Item (Object.Pointer.Value);
else
Object.Pointer := new Reference_Counted_Object;
end if;
Object.Pointer.all := (Value => Value, Count => 1);
return Object;
end Pointer;
function Value (Pointer : Pointer_Type) return Access_Type is
begin
if Pointer.Pointer = null then
return null;
else
return Pointer.Pointer.Value;
end if;
end Value;
procedure Finalize (Object : in out Pointer_Type) is
begin
if Object.Pointer /= null then
Object.Pointer.Count := Object.Pointer.Count - 1;
if Object.Pointer.Count = 0 then
Delete_Item (Object.Pointer.Value);
Delete_Pointer (Object.Pointer);
end if;
end if;
end Finalize;
procedure Adjust (Object : in out Pointer_Type) is
begin
if Object.Pointer /= null then
Object.Pointer.Count := Object.Pointer.Count + 1;
end if;
end Adjust;
end JE.Pointers;
(See chapter 18)
with Ada.Finalization, Ada.Exceptions, JE.Lists, JE.Pointers;
use Ada.Finalization;
package JE.Spreadsheets is
type Spreadsheet_Type is abstract tagged limited private;
type Cell_Type (Sheet : access Spreadsheet_Type'Class)
is abstract tagged limited private;
type Formula_Cell_Type (Sheet : access Spreadsheet_Type'Class;
Size : Natural)
is new Cell_Type(Sheet) with private;
type String_Cell_Type (Sheet : access Spreadsheet_Type'Class;
Size : Natural)
is new Cell_Type(Sheet) with private;
type Cell_Access is access Cell_Type'Class;
function Formula_Cell (Sheet : access Spreadsheet_Type;
Value : String) return Cell_Access;
function String_Cell (Sheet : access Spreadsheet_Type;
Value : String) return Cell_Access;
procedure Evaluate (Cell : in out Cell_Type) is abstract;
function Text_Value (Cell : Cell_Type) return String is abstract;
function Contents (Cell : Cell_Type) return String is abstract;
function Num_Value (Cell : Cell_Type) return Integer is abstract;
procedure Recalculate (Sheet : in out Spreadsheet_Type);
procedure Display (Sheet : in out Spreadsheet_Type) is abstract;
procedure Change (Sheet : in out Spreadsheet_Type);
function Changed (Sheet : Spreadsheet_Type) return Boolean;
function Cell (Sheet : Spreadsheet_Type;
Where : String) return Cell_Access;
procedure Delete (Sheet : in out Spreadsheet_Type;
Where : in String);
procedure Insert (Sheet : in out Spreadsheet_Type;
Where : in String;
What : in Cell_Access);
Cell_Name_Length : constant := 6;
Circularity_Error : exception;
Undefined_Cell_Error : exception;
private
type Cell_State_Type is (Unknown, Defined, Undefined,
Evaluating, Error);
type Evaluation_Number is mod 2;
type Cell_Type (Sheet : access Spreadsheet_Type'Class) is
abstract new Limited_Controlled with
record
State : Cell_State_Type := Unknown;
Eval : Evaluation_Number;
end record;
type Formula_Cell_Type (Sheet : access Spreadsheet_Type'Class;
Size : Natural) is new Cell_Type(Sheet) with
record
Text : String(1..Size);
Value : Integer;
end record;
procedure Evaluate (Cell : in out Formula_Cell_Type);
function Text_Value (Cell : Formula_Cell_Type) return String;
function Contents (Cell : Formula_Cell_Type) return String;
function Num_Value (Cell : Formula_Cell_Type) return Integer;
type String_Cell_Type (Sheet : access Spreadsheet_Type'Class;
Size : Natural) is
new Cell_Type(Sheet) with
record
Text : String(1..Size);
end record;
procedure Evaluate (Cell : in out String_Cell_Type);
function Text_Value (Cell : String_Cell_Type) return String;
function Contents (Cell : String_Cell_Type) return String;
function Num_Value (Cell : String_Cell_Type) return Integer;
subtype Cell_Size is Natural range 0 .. Cell_Name_Length;
package Cell_Pointers is new JE.Pointers (Cell_Type'Class,
Cell_Access);
type Cell_Record is
record
Where : String (1..Cell_Name_Length);
Size : Cell_Size;
Cell : Cell_Pointers.Pointer_Type;
end record;
package Cell_Lists is new JE.Lists (Cell_Record);
type Spreadsheet_Type is
abstract tagged limited record
Cells : Cell_Lists.List_Type;
Dirty : Boolean := False;
Eval : Evaluation_Number := Evaluation_Number'First;
end record;
procedure Updated (Sheet : in out Spreadsheet_Type);
procedure Handle_Error
(Sheet : access Spreadsheet_Type;
Error : in Ada.Exceptions.Exception_Occurrence);
function Evaluation (Sheet : Spreadsheet_Type)
return Evaluation_Number;
end JE.Spreadsheets;
----------------- Package body -----------------
with JE.Expressions.Spreadsheet, Ada.Characters.Handling;
use JE.Expressions.Spreadsheet, Ada.Characters.Handling;
package body JE.Spreadsheets is
use Cell_Lists, Cell_Pointers;
function Formula_Cell (Sheet : access Spreadsheet_Type'Class;
Value : String) return Cell_Access is
Cell : Cell_Access := new Formula_Cell_Type(Sheet, Value'Length);
begin
Formula_Cell_Type(Cell.all).Text := Value;
return Cell;
end Formula_Cell;
function String_Cell (Sheet : access Spreadsheet_Type;
Value : String) return Cell_Access is
Cell : Cell_Access := new String_Cell_Type(Sheet, Value'Length);
begin
String_Cell_Type(Cell.all).Text := Value;
return Cell;
end String_Cell;
procedure Recalculate (Sheet : in out Spreadsheet_Type) is
Iter : Cell_Lists.List_Iterator;
Cell : Cell_Pointers.Pointer_Type;
begin
Sheet.Eval := Sheet.Eval + 1; -- increment evaluation number
if Changed(Spreadsheet_Type'Class(Sheet)) then
Iter := First(Sheet.Cells);
while Iter /= Last(Sheet.Cells) loop
Cell := Value(Iter).Cell;
Evaluate (Value(Cell).all);
Iter := Succ(Iter);
end loop;
Updated (Spreadsheet_Type'Class(Sheet));
end if;
end Recalculate;
procedure Change (Sheet : in out Spreadsheet_Type) is
begin
Sheet.Dirty := True;
end Change;
procedure Updated (Sheet : in out Spreadsheet_Type) is
begin
Sheet.Dirty := False;
end Updated;
function Changed (Sheet : Spreadsheet_Type) return Boolean is
begin
return Sheet.Dirty;
end Changed;
function Cell (Sheet : Spreadsheet_Type;
Where : String) return Cell_Access is
Iter : Cell_Lists.List_Iterator := Cell_Lists.First(Sheet.Cells);
Cell : Cell_Record;
begin
while Iter /= Cell_Lists.Last(Sheet.Cells) loop
Cell := Cell_Lists.Value(Iter);
exit when To_Upper(Cell.Where(1..Cell.Size)) = To_Upper(Where);
Iter := Cell_Lists.Succ(Iter);
end loop;
if Iter /= Cell_Lists.Last(Sheet.Cells) then
return Value(Cell_Lists.Value(Iter).Cell);
else
return null;
end if;
end Cell;
procedure Delete (Sheet : in out Spreadsheet_Type;
Where : in String) is
Iter : Cell_Lists.List_Iterator;
Cell : Cell_Record;
begin
Iter := Cell_Lists.First (Sheet.Cells);
while Iter /= Cell_Lists.Last (Sheet.Cells) loop
Cell := Cell_Lists.Value(Iter);
if To_Upper(Cell.Where(1..Cell.Size)) = To_Upper(Where) then
Delete (Iter);
Change (Spreadsheet_Type'Class(Sheet));
exit;
end if;
Iter := Cell_Lists.Succ(Iter);
end loop;
end Delete;
procedure Insert (Sheet : in out Spreadsheet_Type;
Where : in String;
What : in Cell_Access) is
New_Cell : Cell_Record;
begin
Delete (Sheet, Where);
if What /= null then
New_Cell.Size := Integer'Min(Cell_Name_Length,Where'Length);
New_Cell.Where (1..New_Cell.Size) :=
Where (Where'First .. Where'First+New_Cell.Size-1);
New_Cell.Cell := Pointer(What);
Cell_Lists.Insert (Last(Sheet.Cells), New_Cell);
end if;
Change (Spreadsheet_Type'Class(Sheet));
end Insert;
function Evaluation (Sheet : Spreadsheet_Type)
return Evaluation_Number is
begin
return Sheet.Eval;
end Evaluation;
function Text_Value (Cell : String_Cell_Type) return String is
begin
return Cell.Text;
end Text_Value;
function Contents (Cell : String_Cell_Type) return String is
begin
return Cell.Text;
end Contents;
procedure Evaluate (Cell : in out String_Cell_Type) is
begin
Cell.State := Undefined;
end Evaluate;
function Num_Value (Cell : String_Cell_Type) return Integer is
begin
raise Undefined_Cell_Error;
return 0; -- to keep some compilers happy!
end Num_Value;
function Text_Value (Cell : Formula_Cell_Type) return String is
begin
if Cell.State = Defined then
return Integer'Image(Cell.Value);
elsif Cell.State = Error then
return "*ERROR*";
else
return "";
end if;
end Text_Value;
function Contents (Cell : Formula_Cell_Type) return String is
begin
return Cell.Text;
end Contents;
function Num_Value (Cell : Formula_Cell_Type) return Integer is
begin
if Cell.State = Defined then
return Cell.Value;
else
raise Undefined_Cell_Error;
end if;
end Num_Value;
procedure Evaluate (Cell : in out Formula_Cell_Type) is
Expr : Formula_Type (Cell.Sheet);
begin
if Cell.State = Evaluating then
raise Circularity_Error;
elsif Cell.State = Unknown or
Cell.Eval /= Evaluation(Cell.Sheet.all) then
Cell.Eval := Evaluation(Cell.Sheet.all);
Cell.State := Evaluating;
Cell.Value := Evaluate (Expr, Cell.Text);
Cell.State := Defined;
end if;
exception
when Undefined_Cell_Error =>
if Cell.State /= Error then
Cell.State := Undefined;
end if;
when Fault : Circularity_Error | JE.Expressions.Syntax_Error
| Constraint_Error =>
Cell.State := Error;
Handle_Error (Cell.Sheet, Fault);
end Evaluate;
procedure Handle_Error (Sheet : access Spreadsheet_Type;
Error : Ada.Exceptions.Exception_Occurrence) is
begin
null; -- do nothing, but allow for future overriding
end Handle_Error;
end JE.Spreadsheets;
(See chapter 19)
package JE.Spreadsheets.Active is
use JE.Spreadsheets;
type Active_Spreadsheet_Type is abstract new Spreadsheet_Type
with private;
procedure Change (Sheet : in out Active_Spreadsheet_Type);
function Changed (Sheet : Active_Spreadsheet_Type) return Boolean;
type Counting_Cell_Type (Sheet : access Spreadsheet_Type'Class) is
new Cell_Type(Sheet) with private;
function Counting_Cell (Sheet : access Spreadsheet_Type'Class)
return Cell_Access;
procedure Evaluate (Cell : in out Counting_Cell_Type);
function Contents (Cell : Counting_Cell_Type) return String;
function Text_Value (Cell : Counting_Cell_Type) return String;
function Num_Value (Cell : Counting_Cell_Type) return Integer;
private
protected type Shared_Flag_Type is
function State return Boolean;
procedure Set;
procedure Clear;
private
State_Flag : Boolean := False;
end Shared_Flag_Type;
type Active_Spreadsheet_Type is abstract new Spreadsheet_Type with
record
Modified : Shared_Flag_Type;
end record;
procedure Updated (Sheet : in out Active_Spreadsheet_Type);
task type Counter_Task (Sheet : access Spreadsheet_Type'Class) is
entry Get (Value : out Integer);
entry Stop;
end Counter_Task;
type Counting_Cell_Type (Sheet : access Spreadsheet_Type'Class) is
new Cell_Type(Sheet) with
record
Counter : Counter_Task(Sheet);
end record;
procedure Finalize (Object : in out Counting_Cell_Type);
end JE.Spreadsheets.Active;
----------------- Package body -----------------
with Ada.Calendar;
package body JE.Spreadsheets.Active is
use type Ada.Calendar.Time; -- to allow use of "+"
task body Counter_Task is
type Count_Type is mod 10000;
Count : Count_Type := Count_Type'First;
Update_Time : Ada.Calendar.Time := Ada.Calendar.Clock + 5.0;
begin
loop
select
accept Get (Value : out Integer) do
Value := Integer(Count);
end Get;
or
accept Stop;
exit;
or
delay until Update_Time;
Update_Time := Update_Time + 5.0;
Count := Count + 1;
Change (Sheet.all);
end select;
end loop;
end Counter_Task;
protected body Shared_Flag_Type is
function State return Boolean is
begin
return State_Flag;
end State;
procedure Set is
begin
State_Flag := True;
end Set;
procedure Clear is
begin
State_Flag := False;
end Clear;
end Shared_Flag_Type;
procedure Change (Sheet : in out Active_Spreadsheet_Type) is
begin
Sheet.Modified.Set;
end Change;
procedure Updated (Sheet : in out Active_Spreadsheet_Type) is
begin
Sheet.Modified.Clear;
end Updated;
function Changed (Sheet : Active_Spreadsheet_Type) return Boolean is
begin
return Sheet.Modified.State;
end Changed;
procedure Finalize (Object : in out Counting_Cell_Type) is
begin
Object.Counter.Stop;
end Finalize;
function Contents (Cell : Counting_Cell_Type) return String is
begin
return "<5-second counter>";
end Contents;
function Text_Value (Cell : Counting_Cell_Type) return String is
begin
return Integer'Image(Num_Value(Cell));
end Text_Value;
function Num_Value (Cell : Counting_Cell_Type) return Integer is
I : Integer;
begin
Cell.Counter.Get (I);
return I;
end Num_Value;
procedure Evaluate (Cell : in out Counting_Cell_Type) is
begin
Cell.State := Defined;
end Evaluate;
function Counting_Cell (Sheet : access Spreadsheet_Type'Class)
return Cell_Access is
Cell : Cell_Access := new Counting_Cell_Type (Sheet);
begin
return Cell;
end Counting_Cell;
end JE.Spreadsheets.Active;
(See chapter 13)
with JE.Lists;
generic
type Item_Type is private;
package JE.Stacks is
type Stack_Type is limited private;
procedure Push (Stack : in out Stack_Type;
Item : in Item_Type);
procedure Pop (Stack : in out Stack_Type;
Item : out Item_Type);
function Top (Stack : Stack_Type) return Item_Type;
function Size (Stack : Stack_Type) return Natural;
function Empty (Stack : Stack_Type) return Boolean;
Stack_Overflow, Stack_Underflow : exception;
private
package Lists is new JE.Lists (Item_Type);
type Stack_Item;
type Stack_Type is access Stack_Item;
end JE.Stacks;
----------------- Package body -----------------
package body JE.Stacks is
type Stack_Item is
record
L : Lists.List_Type;
end record;
procedure Push (Stack : in out Stack_Type;
Item : in Item_Type) is
begin
if Stack = null then
Stack := new Stack_Item;
end if;
Lists.Insert (Lists.First(Stack.L), Item);
exception
when Storage_Error =>
raise Stack_Overflow;
end Push;
procedure Pop (Stack : in out Stack_Type;
Item : out Item_Type) is
begin
Item := Top(Stack);
Lists.Delete (Lists.First(Stack.L));
exception
when Lists.List_Error =>
raise Stack_Underflow;
end Pop;
function Top (Stack : Stack_Type) return Item_Type is
begin
return Lists.Value(Lists.First(Stack.L));
exception
when Lists.List_Error =>
raise Stack_Underflow;
end Top;
function Size (Stack : Stack_Type) return Natural is
begin
if Stack = null then
return 0;
else
return Lists.Size (Stack.L);
end if;
end Size;
function Empty (Stack : Stack_Type) return Boolean is
begin
return Size(Stack) = 0;
end Empty;
end JE.Stacks;
(See chapter 9)
with Ada.Calendar;
package JE.Times is
subtype Time_Type is Ada.Calendar.Time;
subtype Year_Type is Ada.Calendar.Year_Number;
type Month_Type is (Jan, Feb, Mar, Apr, May, Jun,
Jul, Aug, Sep, Oct, Nov, Dec);
subtype Day_Type is Ada.Calendar.Day_Number;
subtype Hour_Type is Integer range 0..23;
subtype Minute_Type is Integer range 0..59;
subtype Second_Type is Integer range 0..59;
subtype Day_Duration is Ada.Calendar.Day_Duration;
function Clock return Ada.Calendar.Time renames Ada.Calendar.Clock;
function Interval (Days : Natural := 0;
Hours : Natural := 0;
Minutes : Natural := 0;
Seconds : Natural := 0) return Duration;
function Year (Date : Ada.Calendar.Time) return Year_Type
renames Ada.Calendar.Year;
function Month (Date : Time_Type) return Month_Type;
function Day (Date : Ada.Calendar.Time) return Day_Type
renames Ada.Calendar.Day;
function Hour (Date : Time_Type) return Hour_Type;
function Minute (Date : Time_Type) return Minute_Type;
function Second (Date : Time_Type) return Second_Type;
function Time (Year : Year_Type;
Month : Month_Type;
Day : Day_Type;
Hour : Hour_Type := 0;
Minute : Minute_Type := 0;
Second : Second_Type := 0) return Time_Type;
function "+" (Left : Ada.Calendar.Time;
Right : Duration) return Ada.Calendar.Time
renames Ada.Calendar."+";
function "+" (Left : Duration;
Right : Ada.Calendar.Time) return Ada.Calendar.Time
renames Ada.Calendar."+";
function "-" (Left : Ada.Calendar.Time;
Right : Duration) return Ada.Calendar.Time
renames Ada.Calendar."-";
function "-" (Left : Ada.Calendar.Time;
Right : Ada.Calendar.Time) return Duration
renames Ada.Calendar."-";
function "<" (Left, Right : Ada.Calendar.Time) return Boolean
renames Ada.Calendar."<";
function "<="(Left, Right : Ada.Calendar.Time) return Boolean
renames Ada.Calendar."<=";
function ">" (Left, Right : Ada.Calendar.Time) return Boolean
renames Ada.Calendar.">";
function ">="(Left, Right : Ada.Calendar.Time) return Boolean
renames Ada.Calendar.">=";
Time_Error : exception renames Ada.Calendar.Time_Error;
end JE.Times;
----------------- Package body -----------------
package body JE.Times is
Seconds_Per_Minute : constant := 60;
Minutes_Per_Hour : constant := 60;
Hours_Per_Day : constant := 24;
Seconds_Per_Hour : constant := Minutes_Per_Hour * Seconds_Per_Minute;
Seconds_Per_Day : constant := Hours_Per_Day * Seconds_Per_Hour;
type Integer_Time is range 0 .. Seconds_Per_Day;
function Convert_Time (Time : Day_Duration) return Integer_Time is
T : Integer_Time := Integer_Time (Time);
begin
return T mod Integer_Time'Last;
end Convert_Time;
function Interval (Days : Natural := 0;
Hours : Natural := 0;
Minutes : Natural := 0;
Seconds : Natural := 0) return Duration is
begin
return Duration( (Days * Seconds_Per_Day) +
(Hours * Seconds_Per_Hour) +
(Minutes * Seconds_Per_Minute) + Seconds );
end Interval;
function Month (Date : Ada.Calendar.Time) return Month_Type is
begin
return Month_Type'Val (Ada.Calendar.Month(Date) - 1);
end Month;
function Hour (Date : Time_Type) return Hour_Type is
S : Ada.Calendar.Day_Duration := Ada.Calendar.Seconds (Date);
begin
return Hour_Type( Convert_Time(S) / Seconds_Per_Hour );
end Hour;
function Minute (Date : Time_Type) return Minute_Type is
S : Ada.Calendar.Day_Duration := Ada.Calendar.Seconds (Date);
begin
return Minute_Type( (Convert_Time(S) / Seconds_Per_Minute)
mod Minutes_Per_Hour );
end Minute;
function Second (Date : Time_Type) return Second_Type is
S : Ada.Calendar.Day_Duration := Ada.Calendar.Seconds (Date);
begin
return Second_Type( Convert_Time(S) mod Seconds_Per_Minute );
end Second;
function Time (Year : Year_Type;
Month : Month_Type;
Day : Day_Type;
Hour : Hour_Type := 0;
Minute : Minute_Type := 0;
Second : Second_Type := 0) return Time_Type is
Seconds : Day_Duration :=
Day_Duration( (Hour * Seconds_Per_Hour) +
(Minute * Seconds_Per_Minute) + Second );
begin
return Ada.Calendar.Time_Of (Year, Month_Type'Pos(Month) + 1,
Day, Seconds);
end Time;
end JE.Times;
This file is part of
Ada 95: The Craft of Object-Oriented Programming
by John English.
Copyright © John
English 2000. All rights reserved.
Permission is given to redistribute this work for non-profit educational
use only, provided that all the constituent files are distributed without
change.