Previous     Contents     Next

Appendix D: Package listings


D.1 JE
D.2 JE.Appointments
D.3 JE.Appointments.Meetings
D.4 JE.Appointments.Deadlines
D.5 JE.Diaries
D.6 JE.Expressions
D.7 JE.Expressions.Spreadsheet
D.8 JE.Lists
D.9 JE.Menus
D.10 JE.Pointers
D.11 JE.Spreadsheets
D.12 JE.Spreadsheets.Active
D.13 JE.Stacks
D.14 JE.Times

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.


D.1 JE

(See chapter 4)

    package JE is
        -- an empty package!
    end JE;

D.2 JE.Appointments

(See chapters 10, 14 and 15)

    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;

D.3 JE.Appointments.Meetings

(See chapters 14 and 15)

    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;

D.4 JE.Appointments.Deadlines

(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;

D.5 JE.Diaries

(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;

D.6 JE.Expressions

(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;

D.7 JE.Expressions.Spreadsheet

(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;

D.8 JE.Lists

(See chapters 12 and 16)

    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;

D.9 JE.Menus

(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;

D.10 JE.Pointers

(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;

D.11 JE.Spreadsheets

(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;

D.12 JE.Spreadsheets.Active

(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;

D.13 JE.Stacks

(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;

D.14 JE.Times

(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;


 Previous     Contents     Next


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.