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.
$Revision: 1.2 $
$Date: 2001/11/17 12:00:00 $