Ada (llenguatge de programació)

-- fitxer hola.adb

-- mòduls dels quals depèn
with Ada.Text_IO; 

procedure Hola is

 use Ada.Text_IO; -- importa espai de noms

begin
 Put_Line("Hola, món!");
end Hola;

function | procedure | declare
 -- declaracions
begin
 -- instruccions
exception
 -- gestors d'excepcions:
 when E: TipusExcepcio => -- tractament

 when E: others => -- tracta altres excepcions

end NomDelBloc ;

 type Recompte is range 0 .. 999 -- restricció de rang sobre sencers

 type Byte is mod 2**8

 type Hexa is ('0', '9', 'A', 'B', 'C', 'D', 'E', 'F'); 
 type Boolean is (False, True) ;
 type Opcions is (OpcioA, OpcioB, OpcioC)

 type Percentatge is digits 4 range 0.0 .. 1.0 -- coma-flotant precisió amb restricció de rang

 type Durada is delta Resolució_rellotge -- coma-fixa binari

 type Centim_DEuro is delta 0.01 digits 14 -- coma-fixa decimal quan incorpora precisió en dígits,
 -- pels coma-fixa decimals la delta (resolució) ha d'ésser obligatòriament potència de deu.

 -- instància del genèric 'Integer_IO' per a la precisió Long_Integer
 package Long_Integer_IO is new Ada.Text_IO.Integer_IO (Long_Integer)

 -- instància del genèric 'Float_IO' per a la precisió Long_Float
 package Long_Float_IO is new Ada.Text_IO.Float_IO (Long_Float)

 -- instància del genèric 'Fixed_IO' (coma-fixa) per al tipus específic
 type Kilo_Octet is delta 2.0**10 ;
 package Kilo_Octet_IO is new Ada.Text_IO.Fixed_IO (Kilo_Octet) ;

 -- instància del genèric 'Enumeration_IO' per al tipus específic
 type Discret is (OPCIO_A, OPCIO_B) ;
 package Discret_IO is new Ada.Text_IO.Enumeration_IO (Discret) ;

 -- instància del genèric 'Modular_IO' per al tipus específic
 type Byte is mod 2**8 ;
 package Byte_IO is new Ada.Text_IO.Modular_IO (Byte) ;

-- lectura
 Positive'First -- el primer del tipus

-- escriptura
 for Tipus'Atribut use ValorNouDeLAtribut -- modificació d'atributs actualitzables

-- constructor i components especificant '(x ,..) l'atribut per defecte: el constructor 
 K: Positive := Positive'(10) 

-- conversió amb NomDelTipus(expressió)
 Percentatge(Valor/100.0)

 type Poma is new Recompte range 0 .. 100

 subtype OuDeLaDotzena is OuDelGalliner range 0 .. 12

 type Registre is record
 A, B : Boolean;
 Mida : Positive;
 end record;
 VarR : Registre := (A => False, B => True, Mida => 10) ;

 -- Amb ''access''/''access constant'' només poden apuntar dins el propi dipòsit de dades (''storage pool'')
 type PunterARegistre is  access Registre -- accés RW (només pot apuntar dins el dipòsit de dades del tipus)
 type PunterARegistre is  access constant Registre -- accés RO

 -- Amb ''access all'' els punters no tenen restriccions d'apuntament.
 type PunterARegistre is  access all Registre -- accés RW (all: sense restricció de dipòsit d'apuntament)

 punterARegistreTal.all := (A => False, B => True, Mida => 10) ;

 type Tupla is record -- no limitat, admet assignació (:=) i comparació bit a bit (=) del registre
 A, B : Boolean;
 end record; 

 type Llista is limited record -- limitat, assignació (:=) i comparació bit a bit (=) prohibides
 -- la comparació estructural, quan hi ha punters, no es pot basar 
 -- en la igualtat bit a bit de la primera cel·la.
 Cap: Integer ;
 Cua: access constant Llista -- PunterALlista 
 end record ;

 type VectorDeSencers is array (1 .. 10) of Integer
 -- exemple d'ús amb inicialització 
 -- (el d'índex 1 => 15, el segon 16, altres => valor_per_defecte)
 VA: VectorDeSencers := (1 => 15, 2 => 16, others => 0)

 type BUFFER(MIDA : BUFFER_SIZE := 100) is 
 record
 Posicio : BUFFER_SIZE := 0;
 Valor : STRING(1 .. MIDA);
 end record;

 type TIP_ARBRE is (FULLA, BRANCA) ;

 type ARBRE_DE_SENCERS(Constructor: TIP_ARBRE) is record -- registre variant
 case Constructor is
 when FULLA => dadaFulla: Integer ;
 when BRANCA => dadaNus: Integer ;
 esquerre,dreta: access ARBRE_DE_SENCERS; -- punters a arbres
 end case ;
 end record ;

 generic
 type Item is private; -- paràmetre de tipus opac 
 type Poma is range <>; -- paràmetre de tipus enter, <>: abstracte en el rang 
 type Mass is digits <>; -- paràmetre de tipus coma flotant, <>: abstracte en la precisió 
 type Angle is delta <>; -- paràmetre de tipus coma fixa binari, <>: abstracte en la resolució (valor mínim)
 type Esdeveniment is (<>); -- paràmetre de tipus enumerable (pels parèntesis) <>: abstracte en els valors

 type Buffer(Length : Natural) is limited private; -- paràmetre de tipus indexat 
 -- (limited: assig. i comparació superficials prohibides (quan hi ha punters)) (private: opac)


 type Table is array (Esdeveniment) of Item; -- paràmetre de tipus vector amb tipus d'elements i d'índex declarats prèviament

pragma Assert( boolean_expression string_expression]);

generic
 type Elem is private;

package Piles is
 type Pila is private;

 function Es_Buit(S: Pila) return Boolean;
 function Es_Ple(S: Pila) return Boolean;

 procedure Apila(S: in out Pila; X: in Elem)
 with
 Pre => not Es_Ple(S),
 Post => not Es_Buit(S);

 procedure Desapila(S: in out Pila; X: out Elem)
 with
 Pre => not Es_Buit(S),
 Post => not Es_Ple(S);
private
 ...
end Stacks;

type Punter_A_Sencer is access Integer ;
for Punter_A_Sencer'Storage_Pool use Nom_del_Pool; -- assignació de Storage_Pool específic a un tipus

package Persona is
 type Objecte is tagged -- ''etiquetat'' (defineix el tipus com a constitutiu de classe)
 private ; -- private: definició opaca dels camps

 procedure MètodeDeLaInstància (This : Objecte); -- la instància és el primer paràmetre

 procedure MètodeEstàtic (Param: Integer); -- no duu la instància com a primer paràmetre

 function To_String(This: Objecte) return String; -- per a l'exemple a ''herència''

 -- submòdul 
 package Eines is
 -- Generadors i Funcions que no volem que s'heretin han d'estar en un submòdul.
 function Nou_Persona (...) return Objecte ;
 end Eines ;
private
 type Objecte is tagged record -- camps de dades del tipus de la classe
 Nom : String (1 .. 10);
 Gènere : Tipus_Gènere;
 end record;
end Persona;

with Persona;

package Programador is
 type Objecte is new Persona.Objecte -- nou tipus ''Objecte'' derivat de Persona.Objecte
 with private; -- opac, definit a l'àrea privada

 overriding function To_String(This: Objecte) return String; 

 type Llenguatge is (LLENG_ADA, HASKELL, OCAML); -- ADA és paraula reservada

 package Eines is -- submòdul per a funcions no heretables

 function Nou_programador (pers: Persona.Objecte; esp: Llenguatge) return Objecte ;
 end Eines ;

private
 type Objecte is new Persona.Objecte with -- objecte derivat del tipus de la superclasse
 record -- ampliació del registre de camps 
 Especialitat : Llenguatge;
 end record;
end Programador;

-- implementació
with Ada.Text_IO ;
with Ada.Strings ;

package body Programador is

 package body Eines is
 function Nou_programador (pers: Persona.Objecte; esp: Llenguatge) return Objecte is
 begin
 return Objecte'(pers with Especialitat => esp); -- extensió de registre
 end ;
 end Eines ;

 package Llenguatge_IO is new Ada.Text_IO.Enumeration_IO (Llenguatge) ;

 function To_String(This: Objecte) return String is
 str_Esp: String (1..20) ;
 begin
 Llenguatge_IO.Put(To => str_Esp, Item => This.Especialitat) ;

 return (Persona.To_String(-- crida al mateix mètode, a la superclasse
 Persona.Objecte(This)) -- caracterització a la superclasse
 & "; Especialitat: " & str_Esp) ;
 end ;
 ...
end Programador ;

package Imprimible is

 type Objecte is interface;

 procedure Imprimeix (This : Objecte) is abstract; -- is abstract => cal implementar-lo en classes derivades.
 procedure UnAltreMètode (This : Objecte) is null; -- is null => buit, no requereix implem. en classes derivades.

end Imprimible;

with Programador ;
with Imprimible ;

package ProgramadorAmbImprimible is

 type Objecte is new Programador.Objecte -- derivat de Programador.Objecte
 and Imprimible.Objecte -- i també de Imprimible.Objecte
 with private; 

 procedure Imprimeix (This : Objecte) ; -- redefineix el procediment virtual (abstracte a Imprimible)

private 
 -- declaració privada
end ProgramadorAmbImprimible ;

package body ProgramadorAmbImprimible is

 procedure Imprimeix (This : Objecte) is -- implementa Imprimible 
 begin
 ...
 end ;
end ProgramadorAmbImprimible ;

 -- força la inicialització prèvia del mòdul_M i els mòduls que importi.
 -- alterant l'ordre d'exec. de les inicialitzacions al procés autogenerat ''adainit''
 Pragma Elaborate_All (mòdul_M)

-- fitxer la_meva_biblio.ads -- signatura

generic 
 type T is private; -- paràmetre de tipus (''private'': tipus opac)
 with function Producte (X, Y: T) return T; -- paràmetre funció
 -- el param. actual ha de coincidir en la signatura de la funció

package La_Meva_Biblio is

 function Quadrat (x:T) return T ;

end La_Meva_Biblio ;

-- fitxer la_meva_biblio.adb -- implementació

package body La_Meva_Biblio is

 -- implementa Quadrat basat en la funció Producte que és paràmetre del genèric
 function Quadrat (x:T) return T is
 begin
 return Producte (x, x) ;
 end quadrat ;

end La_Meva_Biblio ;

-- fitxer el_meu_functor.ads -- signatura
with La_Meva_Biblio ;

generic 
 with package Biblio is new La_Meva_Biblio (<>); -- mòdul formal. cal que el mòdul paràmetre actual n'implementi la signatura
 -- en aquest cas, cal que sigui derivat de La_Meva_Biblio
 -- <>: indefinit en la parametrització (abstracte)

package El_meu_functor is

 use Biblio; -- incorpora l'espai de noms del mòdul formal

 function Cub(x: T) return T ;

 function Quadrat(x: T) return T renames Biblio.quadrat; -- publica una funció del mòdul formal

end El_meu_functor ;

-- fitxer el_meu_functor.adb -- implementació
package body El_Meu_Functor is

 function Cub (x:T) return T is
 begin
 return Producte (Quadrat(x), x) ;
 end ;

end El_Meu_Functor ;

-- fitxer principal.adb

-- paquets per relligar amb el ''linker''
with La_Meva_Biblio ;
with El_Meu_Functor ;
with Ada.Text_IO; 

procedure Principal is
 -- nom curt per al mòdul
 package TextIO renames Ada.Text_IO ;

 -- instanciem mòduls genèrics per a l'entrada/sortida dels tipus primitius per als tipus concrets

 package IntIO is new Ada.Text_IO.Integer_IO (Integer); -- Integer_IO per a precisió Integer
 package LFloatIO is new Ada.Text_IO.Float_IO (Long_Float) ; -- Float_IO per a precisió Long_Float
 package BoolIO is new Ada.Text_IO.Enumeration_IO (Boolean) ; -- Enumeration_IO per al cas Boolean

 -- instanciem biblioteques

 package La_Meva_Biblio_sobre_Sencers is new La_Meva_Biblio(T => Integer, Producte => "*") ;
 package La_Meva_Biblio_sobre_Reals is new La_Meva_Biblio(T => Long_Float, Producte => "*") ;

 package El_Meu_Functor_sobre_Sencers is new El_Meu_Functor(La_Meva_Biblio_sobre_Sencers) ;
 package El_Meu_Functor_sobre_Reals is new El_Meu_Functor(La_Meva_Biblio_sobre_Reals) ;

 -- declaració variables

 i : constant Integer := 2 ;
 j,k : Integer ;
 x : constant Long_Float := 2.0 ;
 y,z : Long_Float ;

 comprovacio: Boolean ;

begin
 j := La_Meva_Biblio_sobre_Sencers.Quadrat(i) ;
 y := La_Meva_Biblio_sobre_Reals.Quadrat(x) ;

 k := El_Meu_Functor_sobre_Sencers.Cub(i) ;
 z := El_Meu_Functor_sobre_Reals.Cub(x) ;

 TextIO.Put("Quadrat i Cub de 2 Integer, i comprovació:");
 IntIO.Put(j, Width => 4); -- format: %4d
 IntIO.Put(k, 4) ;

 comprovacio := j = El_Meu_Functor_sobre_Sencers.Quadrat(i) ;

 TextIO.Put(" ") ;
 BoolIO.Put(comprovacio) ;

 TextIO.New_Line(Spacing => 2); -- spacing: nombre de salts de línia

 TextIO.Put("Quadrat i Cub de 2.0 Long_Float, i comprovació:");
 LFloatIO.Put(y, Fore => 3, Aft => 2, Exp => 0); -- format: %3.2f; Exp (dígits exponent)
 LFloatIO.Put(z, 3, 2, 0) ;

 comprovacio := y = El_Meu_Functor_sobre_Reals.Quadrat(x) ;

 TextIO.Put(" ") ;
 BoolIO.Put(comprovacio) ;

 TextIO.New_Line; 

end Principal;

-- fitxer definicions.ads
package Definicions is
 TITOL_APLICACIO : constant String := "Títol_aplicació" ;
end Definicions ;

-- fitxer imprimible.ads -- només signatura
package Imprimible is

 type Objecte is interface ;

 procedure Imprimeix(obj: Objecte) is abstract; -- is abstract => cal redefinir-lo en la classe derivada
 -- procedure Imprimeix(obj: Objecte) is null; -- is null => no implementat, no és obligat redefinir-lo

end Imprimible ;

-- fitxer la_meva_biblio.ads -- signatura
with Persona ;
with Imprimible ;

generic 
 type T is new Persona.Objecte and Imprimible.Objecte with private; -- tipus formal 
 -- (cal que sigui derivat de Persona.Objecte 
 -- i que implementi Imprimible.Objecte)

package La_Meva_Biblio is

 procedure ImprimeixISaltaLinia (obj:T) ;

end La_Meva_Biblio ;

-- fitxer la_meva_biblio.adb -- implementació
with Ada.Text_IO ;
with Ada.Text_IO.Bounded_IO ;

with Ada.Strings ;
with Ada.Strings.Bounded;

package body La_Meva_Biblio is

 MAX_BUF : constant Integer := 20 ;
 package SB_Buf is new Ada.Strings.Bounded.Generic_Bounded_Length (MAX_BUF) ;
 package SB_Buf_IO is new Ada.Text_IO.Bounded_IO(SB_Buf) ;

 package TextIO renames Ada.Text_IO ;

 títol: SB_Buf.Bounded_String ;

 procedure ImprimeixISaltaLinia (obj:T) is
 begin
 SB_Buf_IO.Put (títol) ;
 Imprimeix (obj) ;
 TextIO.New_Line(Spacing => 1) ;

 end ImprimeixISaltaLinia ;

begin -- inicialització de mòdul
 -- útil per inicialitzacions que depenen d'un altre mòdul

 títol := SB_Buf.To_Bounded_String(Definicions.TITOL_APLICACIO & ": ") ;

end La_Meva_Biblio ;

-- fitxer persona.ads -- signatura
with Ada.Strings.Bounded; -- cadenes de text acotades

package Persona is

 type Objecte is tagged private; -- ''tagged'': objectes, ''private'': opac, definit a l'àrea privada

 function Put_To_String(obj: Objecte) return String ;

 package Eines is -- mòdul niuat per a les funcions que no volem virtuals (heretables)

 function Nou_Persona(nom: String; edat: Integer) return Objecte ;
 end Eines ;

 MAX_NOM : constant integer := 16 ;
 package SB_Nom is new Ada.Strings.Bounded.Generic_Bounded_Length (MAX_NOM) ;

private 
 type Objecte is tagged record
 Nom: SB_Nom.Bounded_String ;
 Edat: Integer ;
 end record ;

end Persona;

-- fitxer persona.adb -- implementació
with Ada.Text_IO ;
with Ada.Strings ;
with Ada.Strings.Fixed ;
with Ada.Strings.Bounded ;

package body Persona is

 package IntIO is new Ada.Text_IO.Integer_IO (Integer) ;

 package body Eines is -- mòdul niuat per les funcions que no volem virtuals (heretables)

 function Nou_Persona(nom: String; edat: Integer) return Objecte is
 begin
 return Persona.Objecte'(Nom => Persona.SB_Nom.To_Bounded_String(nom)
			, Edat => edat
			) ;
 exception
 when E: Ada.Strings.Length_Error =>
 Ada.Text_IO.Put("error: nom massa llarg, màxim: ") ;
 IntIO.Put(MAX_NOM) ;
 Ada.Text_IO.New_Line(1) ;
 raise ;

 end Nou_Persona ;
 end Eines ;

-----------------------
 function Put_To_String(obj: Objecte) return String is

 MAX_BUF : constant Integer := 40 ;
 package SB_Buf is new Ada.Strings.Bounded.Generic_Bounded_Length (MAX_BUF) ;

 sb_buf1: SB_Buf.Bounded_String ;
 buf2: String (1 .. 10) ;

 use SB_Buf; -- incorpora espai de noms
 use Ada.Strings ;

 begin
 sb_buf1 := To_Bounded_String(SB_Nom.To_String(obj.nom)) ;

 IntIO.Put (To => buf2, Item => obj.edat) ;

 return To_String(sb_buf1 & " " & Fixed.Trim(buf2, Left)) ;
 end Put_To_String ;

end Persona;

-- fitxer programador.ads -- signatura
with Persona ;
with Imprimible ;

package Programador is

 type Objecte is new Persona.Objecte -- deriva de Persona.Objecte 
 and Imprimible.Objecte -- i també de Imprimible.Objecte
 with private; -- extensió de camps opaca (a l'àrea privada)

 overriding function Put_To_String(obj: Objecte) return String; -- sobrescriu mètode de la superclasse

 procedure Imprimeix (obj: Objecte) ;

 type Llenguatge is (LLENG_ADA, HASKELL, OCAML, SCALA); -- LLENG_ADA doncs ADA és nom reservat

 package Eines is -- mòdul niuat per les funcions que no volem virtuals (heretables)

 function Nou_Programador(nom: String; edat: Integer; especialitat: Llenguatge) 
		 return Objecte ;
 end Eines ;

private

 type Objecte is new Persona.Objecte and Imprimible.Objecte with record -- extensió de registre de camps

 Especialitat: Llenguatge ;
 end record; 

end Programador;

-- fitxer programador.adb -- implementació
with Ada.Text_IO ;
with Ada.Strings ;
with Ada.Strings.Bounded ;

package body Programador is

 package body Eines is -- mòdul niuat per les funcions que no volem virtuals (heretables)

 function Nou_Programador(nom: String; edat: Integer; especialitat: Llenguatge) 
		 return Objecte is
 begin
 return Objecte'(Persona.Eines.Nou_Persona(nom, edat) with Especialitat => especialitat) ;
 end Nou_Programador ;
 end Eines ;

------------
 function Put_To_String(obj: Objecte) return String is

 package Llenguatge_IO is new Ada.Text_IO.Enumeration_IO(Llenguatge) ;

 MAX_BUF : constant Integer := 60 ;
 package SB_Buf is new Ada.Strings.Bounded.Generic_Bounded_Length (MAX_BUF) ;

 sb_buf1: SB_Buf.Bounded_String ;
 buf2: String (1 .. 12) ;

 use SB_Buf; -- incorpora espai de noms

 begin
 sb_buf1 := To_Bounded_String(
 Persona.Put_To_String(-- crida al mètode homònim de la superclasse
 Persona.Objecte(obj) -- cal fer un ''up-cast'' (caracterització) de l'objecte 
 -- al supertipus corresp. al mètode
)) ;

 Llenguatge_IO.Put(buf2, obj.especialitat) ;

 return To_String(sb_buf1 & " " & buf2) ;
 end Put_To_String ;

------------
 procedure Imprimeix (obj: Objecte) is

 package TextIO renames Ada.Text_IO ;

 begin
 TextIO.Put ("Programador: ") ;
 TextIO.Put (Put_To_String(obj)) ;
 end Imprimeix ;

end Programador;

-- fitxer principal.adb
with La_Meva_Biblio ;
with Programador ;

procedure Principal is

 package La_Meva_Biblio_ProgImp is new La_Meva_Biblio(T => Programador.Objecte) ;

 obj : Programador.Objecte ;

 use Programador; -- incorpora espai de noms del mòdul
 use La_Meva_Biblio_ProgImp ;

begin
 obj := Eines.Nou_Programador("Gabriel", 59, Especialitat => HASKELL) ;

 ImprimeixISaltaLinia(obj) ;
end Principal;

task: fil d'execució (ang: ''thread'')

entry: canal d'entrada (bústia de comunicació amb cua de missatges)

(when condició => accept canal) : entrada del canal amb guarda (procés condicionat)

-- fitxer prova.adb
with Ada.Strings ;
with Ada.Strings.Fixed ;
with Ada.Strings.Bounded ;

with Ada.Text_IO ;
with Ada.Text_IO.Bounded_IO ;

procedure Prova is
 package TextIO renames Ada.Text_IO ;

 str1 : String := "abcdefghi" ;
 MAX_BUF : constant Integer := str1'Last ;

 package SB_Buf is new Ada.Strings.Bounded.Generic_Bounded_Length (MAX_BUF) ;
 package SB_Buf_IO is new Ada.Text_IO.Bounded_IO(SB_Buf) ;

 sb_buf2 : SB_Buf.Bounded_String ;

 type T_ESTAT is range 1..(MAX_BUF +1) ;

 task Automata is -- task és fil d'execució (''thread'')
 entry Llegeix(ch: in Character); -- canal d'entrada
 entry Imprimeix; -- canal d'entrada
 end Automata ;

 task body Automata is -- l'activació s'inicia en completar la inicialització de l'objecte que l'enclou

 Estat: T_ESTAT := T_ESTAT'First ;
 -- use SB_Buf ;
 begin
 loop
 select
	when Estat < T_ESTAT'Last =>
		accept Llegeix(ch: in Character) do

 SB_Buf.Append(sb_buf2, ch) ;
 TextIO.Put(ch); -- fem l'eco 
		end Llegeix ;
		Estat := Estat +1 ;
 or
 when Estat = T_ESTAT'Last =>
	 accept Imprimeix do

 TextIO.New_Line ;
		SB_Buf_IO.Put(sb_buf2) ;
	 end Imprimeix ;
 or 
 terminate; -- acaba quan hi ha una opció ''terminate'' oberta
 -- i no hi ha entrades pendents 
 -- i totes les tasques (fils d'execució) estan igual 
 -- i el procés principal enllesteix.

 -- o bé, en comptes d'acabar, especificar un lapse de temps i les accions a prendre

 delay 1.0; TextIO.New_Line -- termini i accions subseqüents al venciment

 end select ;
 end loop ;

 end Automata ;
begin
 for i in str1'Range loop

 Automata.Llegeix(str1(i)) ;
 delay 0.2 ;

 end loop ;
 Automata.Imprimeix ;

end prova ;

select
 -- ''delay or triggering statement''
 delay 5.0;
 Put_Line("El càlcul no convergeix");
then abort
 -- Aquest càlcul està limitat en temps pel termini prèviament esmentat
 Càlcul_que_pot_excedir_el_temps_tolerable(X, Y) ;
end select;

-- fitxer prova.adb -- procés cua d'esdeveniments

with Ada.Text_IO ;
with Ada.Containers.Doubly_Linked_Lists ;

procedure Prova is

 package TextIO renames Ada.Text_IO ;

 type TEsdeveniment is (SUCCES_A, SUCCES_B, FINAL) ;

 package TEsdeveniment_IO is new Ada.Text_IO.Enumeration_IO (TEsdeveniment) ;

 package Cua_Esdev is new Ada.Containers.Doubly_Linked_Lists (TEsdeveniment); -- cua de dos caps, il·limitada

----------------

 protected Cua_Protegida is

 procedure Afegir(Esdev: TEsdeveniment); -- procedure (no bloca) (cua és il·limitada) 
 entry Retirar_Primer(Esdev: out TEsdeveniment); -- entry (pot blocar) (Retirar_Primer requereix cua no buida)
 private
 Cua: Cua_Esdev.List ;
 end Cua_Protegida; 

 protected body Cua_Protegida is

 procedure Afegir(Esdev: TEsdeveniment) is
 begin
 Cua_Esdev.Append(Cua, Esdev) ;
 end Afegir;

 entry Retirar_Primer (Esdev: out TEsdeveniment) -- canal d'entrada 
 when not Cua_Esdev.Is_Empty(Cua) is -- requeriment d'accés
 begin
 Esdev := Cua_Esdev.First_Element(Cua) ;
 Cua_Esdev.Delete_First(Cua) ;
 end Retirar_Primer;

 end Cua_Protegida ;

----------------

 task Processa_Esdeveniments; -- no exporta res

 task body Processa_Esdeveniments is
 Es_Final: Boolean := False ;
 begin
 while not Es_Final loop
 declare
 Esdev: TEsdeveniment ;
 begin

 Cua_Protegida.Retirar_Primer(Esdev) ;

 TEsdeveniment_IO.Put(Esdev) ;
 TextIO.New_Line ;

 Es_Final := Esdev = FINAL ;
 end ;
 end loop ;
 end Processa_Esdeveniments ;

begin
 Cua_Protegida.Afegir (SUCCES_A) ;
 Cua_Protegida.Afegir (SUCCES_B) ;
 delay 1.0 ;

 Cua_Protegida.Afegir (FINAL) ;
end Prova ;

-- fitxer prova_mem.ads

package Prova_Mem is
 procedure Prova ;
end Prova_Mem ;

-- fitxer prova_mem.adb

with Ada.Text_IO ;
with Ada.Unchecked_Deallocation ;
with System.Pool_Local ;
with Ada.Exceptions ;

package body Prova_Mem is

 package Except renames Ada.Exceptions ;

 package Txt_IO renames Ada.Text_IO ;
 package Int_IO is new Ada.Text_IO.Integer_IO (Integer) ;
 package Boolean_IO is new Ada.Text_IO.Enumeration_IO (Boolean) ;

 procedure Prova is

 type Tipus is array (1..1000) of Integer;
 type Ptr_A_Tipus is access Tipus;

 Local_Pool : System.Pool_Local.Unbounded_Reclaim_Pool; -- memòria d'àmbit.
 for Ptr_A_Tipus'Storage_Pool use Local_Pool ;

 procedure Free_Ptr_A_Tipus is new Ada.Unchecked_Deallocation (Tipus, Ptr_A_Tipus);

 subtype Ptr_No_Nul_A_Tipus is not null Ptr_A_Tipus ;

 A : Ptr_A_Tipus;

 procedure Allotja is
 begin
	A := new Tipus'(others=>10); -- allotja i inicialitza
 end Allotja;

 procedure DesAllotja is
 begin
	Free_Ptr_A_Tipus (A);
 end DesAllotja;

 procedure Comprova_Nul (B: Ptr_A_Tipus) is
 begin

 Txt_IO.Put ("Que és nul el punter? ") ;
 Boolean_IO.Put (B = null) ;
 Txt_IO.New_Line ;
 end Comprova_Nul ;

 procedure Imprimeix_Elem (B: Ptr_No_Nul_A_Tipus) is -- restringit pel subtipus, dispara exc. Constraint_Error
 -- procedure Imprimeix_Elem (B: not null access Tipus) is -- alternativa
 vec: Tipus ;
 begin
 vec := B.all ;
 Txt_IO.Put ("El primer elem. és") ;
 Int_IO.Put (vec(1), Width => 4) ;
 Txt_IO.New_Line; 
 end Imprimeix_Elem ;

 begin

 Allotja ;

 A.all := (others => 20) ;

 Comprova_Nul(A) ;

 Imprimeix_Elem(A) ;

 Allotja ;
 DesAllotja; -- A queda ''null''

 Comprova_Nul(A) ;

 begin
 Imprimeix_Elem(A) ;

 exception
 when Constraint_Error => Txt_IO.Put_Line ("Restricció ''not null'' fallida: El punter era nul") ;

 when E: others => Txt_IO.Put_Line ("disparada: " & Except.Exception_Name (E));
 end ;

 Allotja ;
 end Prova; -- el Local_Pool queda fora d'àmbit i se'n reclama la memòria
end Prova_Mem ;

-- fitxer principal.adb

with Prova_Mem ;

procedure Principal is
begin
 Prova_Mem.Prova ;
end ;

-- fitxer controlat.ads
with Carrega ;
with Ada.Finalization; 

package Controlat is

 use Carrega ;

 type Objecte is new Ada.Finalization.Controlled with -- classe derivada de ''Ada.Finalization.Controlled''
 record
 Ptr_A_La_Meva_Carrega: Carrega.Ptr_A_Carrega := null ;
 end record;

private

 procedure Initialize(Obj: in out Objecte); -- constructor buit (cridat quan no hi ha inicialització en la declaració)
 procedure Adjust(Obj: in out Objecte); -- constructor de còpia (ajustatge després de còpia superficial)
 procedure Finalize (Obj: in out Objecte); -- cridat en sortir de l'àmbit o quan l'obj. es deslliga de la variable quan és modificada
end Controlat;

-- fitxer controlat.adb
with Ada.Text_IO; 

package body Controlat is

 package Txt_IO renames Ada.Text_IO ;
 package Int_IO is new Ada.Text_IO.Integer_IO (Integer) ;

 procedure Initialize(Obj: in out Objecte) is -- constructor buit 
 begin
 Txt_IO.Put("Initialize:"); 

 Obj.Ptr_A_La_Meva_Carrega := Carrega.Nova_Carrega (Id => 1); 
 Txt_IO.New_Line ;
 end;

 procedure Adjust(Obj: in out Objecte) is -- constructor de còpia (ajustatge després de còpia superficial bit a bit)
 begin
 Txt_IO.Put("Adjust :"); 

 Carrega.Incr_Refs(Obj.Ptr_A_La_Meva_Carrega) ;
 Txt_IO.New_Line ;
 end;

 procedure Finalize (Obj: in out Objecte) is -- en sortir de l'àmbit o en ésser deslligat de la ref.
 refs: Natural ;
 begin
 Txt_IO.Put("Finalize :"); 
 if not Carrega.Es_Nul (Obj.Ptr_A_La_Meva_Carrega) then 

 Carrega.Decr_Refs(Obj.Ptr_A_La_Meva_Carrega, refs) ;

 if refs = 0 then
	Carrega.Allibera_Carrega (Obj.Ptr_A_La_Meva_Carrega) ;
	Txt_IO.Put("; Desallotjat") ;
 end if ;
 end if ;
 Txt_IO.New_Line ;
 end;
end Controlat;

-- fitxer carrega.ads
with Ada.Unchecked_Deallocation; 

package Carrega is

 type Carrega is private ;

 type Ptr_A_Carrega is access Carrega ;

 function Nova_Carrega (Id: integer) return Ptr_A_Carrega ;
 function Es_Nul(ptr_carr: Ptr_A_Carrega) return Boolean ;

 procedure Incr_Refs (ptr_carr: in Ptr_A_Carrega) ;
 procedure Decr_Refs (ptr_carr: in Ptr_A_Carrega; refs: out Natural) ;

 procedure Allibera_Carrega (ptr_carr: in out Ptr_A_Carrega) ;

 private
 type Carrega is record 
 Id: Integer ;
 Num_Refs: Natural := 1 ;
 end record ;

 procedure Free_Carrega is new Ada.Unchecked_Deallocation (Carrega, Ptr_A_Carrega);

end Carrega;

-- fitxer carrega.adb
with Ada.Text_IO; 

package body Carrega is

 package Txt_IO renames Ada.Text_IO ;
 package Int_IO is new Ada.Text_IO.Integer_IO (Integer) ;

 function Nova_Carrega (Id: integer) return Ptr_A_Carrega is
 Ptr: Ptr_A_Carrega := null ;
 begin
 Ptr := new Carrega'(Id => Id, others => <>); -- ''<>'': valors per defecte

 Txt_IO.Put(" Càrrega Id.: "); Int_IO.Put(Id, 4) ;
 Txt_IO.Put(" Refs: "); Int_IO.Put(Ptr.all.Num_Refs, 4) ;
 Txt_IO.New_Line ;
 return Ptr ;
 end Nova_Carrega ;

 function Es_Nul(ptr_carr: Ptr_A_Carrega) return Boolean is
 begin
 return ptr_carr = null ;
 end ;

 procedure Incr_Refs (ptr_carr: in Ptr_A_Carrega) is
 begin
 ptr_carr.all.Num_Refs := ptr_carr.all.Num_Refs +1 ;

 Txt_IO.Put(" Càrrega Id.: "); Int_IO.Put(ptr_carr.all.Id, 4) ;
 Txt_IO.Put(" Refs: "); Int_IO.Put(ptr_carr.all.Num_Refs, 4) ;
 end ;

 procedure Decr_Refs (ptr_carr: in Ptr_A_Carrega; refs: out Natural) is
 begin
 if ptr_carr.all.Num_Refs > 0 then
 ptr_carr.all.Num_Refs := ptr_carr.all.Num_Refs -1 ;
 end if ;
 refs := ptr_carr.all.Num_Refs ;

 Txt_IO.Put(" Càrrega Id.: "); Int_IO.Put(ptr_carr.all.Id, 4) ;
 Txt_IO.Put(" Refs: "); Int_IO.Put(ptr_carr.all.Num_Refs, 4) ;

 end ;

 procedure Allibera_Carrega (ptr_carr: in out Ptr_A_Carrega) is
 begin
 Free_Carrega(ptr_carr) ;
 end ;

end Carrega;

-- fitxer principal.adb
with Carrega ;
with Controlat ;
with Ada.Finalization; 
with Ada.Text_IO ;

procedure Principal is

 package Txt_IO renames Ada.Text_IO ;

 use Controlat ;
 obj1: Controlat.Objecte; -- Sense inicialitzar, ''Initialize'' s'executa

begin
 declare -- àmbit intern fet a posta per a l'exemple
 obj2: Controlat.Objecte := (Ada.Finalization.Controlled 
 with Ptr_A_La_Meva_Carrega => Carrega.Nova_Carrega (Id => 2)); -- ''Initialize'' no actúa
 obj3: Controlat.Objecte := (Ada.Finalization.Controlled 
 with Ptr_A_La_Meva_Carrega => Carrega.Nova_Carrega (Id => 3)); -- ''Initialize'' no actúa
 begin
 Txt_IO.New_Line; Txt_IO.Put_Line("-- obj2 := obj3 -- finalitza objecte de la var obj2; adjust objecte de la var obj3") ;
 obj2 := obj3; 

 Txt_IO.New_Line; 
 Txt_IO.Put_Line("-- sortida àmbit intern, variables obj2 i obj3 surten del seu àmbit") ;
 end; -- sortida de l'àmbit, 

 Txt_IO.New_Line; 
 Txt_IO.Put_Line("-- sortida àmbit extern, variable obj1 surt de l'àmbit") ;
end Principal;