Dynamic Dispatching with dynamic allocation, Ada

Dynamic Dispatching with dynamic allocation

--GNAT 4.9.3

with Ada.Text_IO; use Ada.Text_IO;
procedure main is

package animals is

type walk is interface;
    function can_walk(self : walk) return boolean is abstract;
    
    type swim is interface;
    function can_swim(self : swim) return boolean is abstract;
    
    type fly is interface;
    function can_fly(self : fly) return boolean is abstract;

type animal is abstract new walk and swim and fly with record
        name : string(1..5);
    end record;
    function can_walk(self : animal) return boolean is abstract;
    function can_swim(self : animal) return boolean is abstract;
    function can_fly(self : animal) return boolean is abstract;
    
    subtype animal_class is animal'class;
    type animal_class_access is access all animal_class;
    type animal_list is array(positive range <>) of animal_class_access;
    
    type mammal is new animal with record
        legs : integer;
        fins : integer;
    end record;
    function can_walk(self : mammal) return boolean;
    function can_swim(self : mammal) return boolean;
    function can_fly(self : mammal) return boolean;
    
    type reptile is new animal with record
        legs : integer;
        fins : integer;
    end record;
    function can_walk(self : reptile) return boolean;
    function can_swim(self : reptile) return boolean;
    function can_fly(self : reptile) return boolean;
    
    type bird is new reptile with record
        wings : integer;
    end record;
    function can_fly(self : bird) return boolean;
    
    package constructor is
        function make_mammal(name : string; legs, fins : integer) return access mammal; 
        function make_reptile(name : string; legs, fins : integer) return access reptile;
        function make_bird(name : string; legs, fins, wings : integer) return access bird;
    end constructor;
   
end animals;

package body animals  is   
    
    function can_walk(self : mammal) return boolean is
    begin
        if self.legs >= 2 then
            return True;
        else 
            return false;
        end if;
    end can_walk;
    
    function can_swim(self : mammal) return boolean is
    begin 
            return false;
    end can_swim;
    
    function can_fly(self : mammal) return boolean is
    begin
            return false;
    end can_fly;
    
    function can_walk(self : reptile) return boolean is
    begin
        if self.legs >= 2 then
            return True;
        else 
            return false;
        end if;
    end can_walk;
    
    function can_swim(self : reptile) return boolean is
    begin
        if self.fins > 0 then
            return True;
        else 
            return false;
        end if;
    end can_swim;
    
    function can_fly(self : reptile) return boolean is
    begin       
            return false;
    end can_fly;
    
    function can_fly(self : bird) return boolean is
    begin
        if self.wings > 0 then
            return True;
        else 
            return false;
        end if;
    end can_fly;
    
    package body constructor is
        function make_mammal(name : string; legs, fins : integer) return access mammal is
            self : access mammal := new mammal'(name => name, legs=> legs, fins=> fins);
        begin
            return  self;
        end make_mammal;
        function make_reptile(name : string; legs, fins : integer) return access reptile is
            self : access reptile := new reptile'(name => name, legs=> legs, fins=> fins);
        begin
            return  self;
        end make_reptile;
        function make_bird(name : string; legs, fins, wings : integer) return access bird is
             super : access reptile := make_reptile(name,legs,fins);
             self : access bird := new bird'(super.all with wings=>wings);             
        begin
            return  self;
        end make_bird;
    end constructor;
    
end animals;
    
    
use animals, animals.constructor;

dog : animal_class_access := make_mammal(name => "dog  ", legs => 4, fins=>0);
snake : animal_class_access := make_reptile(name => "snake", legs => 0, fins=>0);
fish : animal_class_access := make_reptile(name => "fish ", fins => 2, legs=>0);
kite : animal_class_access := make_bird(name => "kite ", wings=>2 , legs => 0, fins=>0);

my_animals : animal_list := (dog,snake,fish,kite);

begin

for i in my_animals'range loop
        Put (my_animals(i).name);

if my_animals(i).can_walk  then
            Put(" walking ");
        elsif not my_animals(i).can_swim and not my_animals(i).can_fly then
            Put(" crawling ");
        end if;
        
        if my_animals(i).can_swim then
            Put (" swimming ");
        end if;
        
        if my_animals(i).can_fly then
            Put (" flying ");
        end if;

new_line;
    end loop;

end main;


run \| edit \| history \| help	1