A. Classes: Tagged Types - JulTob/Ada GitHub Wiki
To implement a proper class you need to use a package just as a library.
Inside it, you define the objects, the constructors, the methods and functions.
A class is the abstract collection of all these to one specific idea or concept.
A class in C++ or Java corresponds to a tagged type in Ada.
type T is tagged record
V, W : Integer;
end record;
type T_Access is access all T;
function F (V: T) return Integer;
procedure P1 (Pnt: access T);
procedure P2 (Pnt: T_Access);
-- Note that P2 is not a primitive of T—it does not have any parameters of type T.
-- Its parameter is of type T_Access, which is a different type.
Once declared, primitives can be called like any subprogram with every necessary parameter specified, or called using prefix notation. For example:
declare
V : T;
begin
V.P1; -- Wait what?? -- Check later
end;
type C (discriminant : type) is new parent_class
and interface
with record
-- Declarations
end record;
Constructors
Constructors are functions that return objects of the class record, instantiated to some values.
function new_Web_Page return Web_Page is
...
Destructors.
Usually automated, processes that deallocate the memory taken by the record object.
Class as Access to structures
Another definition of classes is just accesses to structures. THese can be defined as follows:
declare
type R is Record
A, B: Integer
end record;
type C is access R;
Obj1, Obj2: C;
type A_int is access Integer;
int: A_int := new Integer;
begin
Obj1 := new R;
Obj1.A := 0;
Obj2 := Obj1;
-- They Point to the same object! -- Java style
Obj2.A:= 1;
-- Obj1.A is also 1 now
-- Content access
Obj1.all := (1,0);
Obj2.all := Obj1.all;
Obj2.A := Obj1.all.A;
-- The .all append is optionall if clear it mean
int.all := 0;
-- Specifically refers to cocntent
-- int := 0 mightn semantically mean "Ground-pointer"
end;
---Base.ads
package Base is
type Base_Type is tagged
record
B : Integer;
end record;
procedure P1(X : Base_Type);
procedure P2(X : out Base_Type);
procedure P3(X : Base_Type; Y : Base_Type);
function F return Base_Type;
end Base;
---Base.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Base is
procedure P1(X : Base_Type) is begin
Put_Line("Base.P1"); end P1;
procedure P2(X : out Base_Type) is begin
Put_Line("Base.P2");
X.B := 0;
end P2;
procedure P3(X: Base_Type; Y : Base_Type) is begin
Put_Line("Base.P3");
end;
function F return Base_Type is begin
Put_Line("Base.F");
return (B => 0);
end F;
end Base;
--- Derived.ads
with Base;
package Derived is
type Derived_Type is new Base.Base_Type with
record
D : Integer;
end record;
overriding procedure P1(X : Derived_Type);
overriding procedure P2(X : out Derived_Type);
overriding procedure P3(X : Derived_Type; Y : Derived_Type);
overriding function F return Derived_Type;
end Derived;
--- Derived.adb
with Ada.Text_IO; use Ada.Text_IO;
with Base;
with Derived;
procedure Tagged_Demo is
procedure Test(X : Base.Base_Type'Class) is
Y : Base.Base_Type'Class := X;
begin
Base.P1(X);
Base.P2(Y);
Y := Base.F;
end Test;
procedure Test2 (X, Y : Base.Base_Type'Class) is
begin
Base.P3(X, Y);
end Test2;
X : constant Base.Base_Type := (B => 10);
Y : constant Derived.Derived_Type := (B => 10, D => 20);
begin
Put_Line("Testing regular types.");
Base.P1(X);
-- Base.P1(Y); -- Compile error due to type mismatch.
-- Derived.P1(X); -- Compile error due to type mismatch.
Derived.P1(Y);
New_Line;
Put_Line("Testing class-wide types.");
Test(X);
Test(Y);
Test2(X, X);
-- Test2(X, Y); -- Raises Constraint_Error at run time.
-- Test2(Y, X); -- Raises Constraint_Error at run time.
Test2(Y, Y);
end Tagged_Demo;
--- tagged_Demo.adb
with Ada.Text_IO; use Ada.Text_IO;
with Base;
with Derived;
procedure Tagged_Demo is
procedure Test(X : Base.Base_Type'Class) is
Y : Base.Base_Type'Class := X;
begin
Base.P1(X);
Base.P2(Y);
Y := Base.F;
end Test;
procedure Test2 (X, Y : Base.Base_Type'Class) is
begin
Base.P3(X, Y);
end Test2;
X : constant Base.Base_Type := (B => 10);
Y : constant Derived.Derived_Type := (B => 10, D => 20);
begin
Put_Line("Testing regular types.");
Base.P1(X);
-- Base.P1(Y); -- Compile error due to type mismatch.
-- Derived.P1(X); -- Compile error due to type mismatch.
Derived.P1(Y);
New_Line;
Put_Line("Testing class-wide types.");
Test(X);
Test(Y);
Test2(X, X);
-- Test2(X, Y); -- Raises Constraint_Error at run time.
-- Test2(Y, X); -- Raises Constraint_Error at run time.
Test2(Y, Y);
end Tagged_Demo;
Example: Robots!
ADS
package Asimov is
type Robot is tagged private; --declaration of a class
type Reference is access all Robot'Class -- A classwide access
procedure On(R: in out Robot);
procedure Off(R: in out Robot);
function Is_On(R: in Robot) return Boolean;
private Robot is tagged record -- tagged record = class
On: Boolean := False;
end record;;
end Asimov;
ADB
with Ada.Text_IO; use Ada;
package body Asimov is
function Is_On (R: Robot) return Boolean is
BEGIN RETURN R.IS_ON; end IS_ON;
procedure ON(R: in out Robot) is
begin
R.ON := True;
end ON;
procedure OFF(R: in out Robot) is
begin
R.ON := False;
end OFF;
Un tipo tagged es un tipo privado o un record en cuya declaración se usa la palabra reservada tagged.
Un tipo tagged puede ser extendido, dando lugar a otro tipo que se dice derivado de aquel. El tipo del que se deriva se dice que es "padre" del derivado. Del tipo derivado se pueden a su vez derivar otros, formando una jerarquía de tipos (una familia de tipos). Los tipos derivados también son tagged. Cada objeto tagged tiene un atributo llamado Tag que identifica su clase concreta.
El tipo primitivo de una jerarquía no tiene por qué tener ningún campo, de forma que sólo existan los añadidos por sus extensiones.
package Ejemplo is
type Persona is tagged private; -- Declaración de tipo tagged
private
type Persona is tagged record
Nombre : String (1 .. 50);
NIF : String (1 .. 9);
end record;
end Ejemplo;
Tipo primitivo sin campos:
type Otro is tagged null record;