Llenguatge De Programació 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 [not_null] access Registre -- accés RW (només pot apuntar dins el dipòsit de dades del tipus)  type PunterARegistre is [not_null] access constant Registre -- accés RO   -- Amb ''access all'' els punters no tenen restriccions d'apuntament.  type PunterARegistre is [not_null] 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([Check =>] boolean_expression[, [Message =>] 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;