Programación en Ada/Texto completo

Programación en Ada

gcc --version
gcc (GCC) 3.4.3
Copyright (C) 2004 Free Software Foundation, Inc.

gnat
gnat-runtime

aptitude install gnat

emerge gnat

urpmi gnat

with Ada.Text_IO;

procedure Hola_Mundo is
begin
   Ada.Text_IO.Put_Line("¡Hola, mundo!");
end Hola_Mundo;

main
"¡Hola, mundo!"
-- Con clásula use
with Ada.Text_IO; use Ada.Text_IO;

procedure Hola_Mundo is
begin
   Put_Line("¡Hola, mundo!");
end Hola_Mundo;

-- Con cláusula renames
with Ada.Text_IO; use Ada.Text_IO;

procedure Hola_Mundo is
   package T_IO renames Ada.Text_IO;
begin
   T_IO.Put_Line("¡Hola, mundo!");
end Hola_Mundo;

gnatmake hola_mundo.adb

Temperatura_Sala := 25;  -- Temperatura que debe tener la sala.

identificador ::= letra { [ subrayado ] letra | cifra }
letra ::= A | ... | Z | a | ... | z
cifra ::= 0 | ... | 9
subrayado ::= _

'A' 'ñ' '%'

&    '    (    )    *    +    ,    -    .    /    :    ;    <    =    >    

=>    ..    **    :=    /=    >=    <=    <<    >>    <>

--
-- Este comentario ocupa una línea completa.
Mis_Ahorros := Mis_Ahorros * 10.0; -- Este está después de una sentencia.
Mis_Ahorros := Mis_Ahorros * -- Este está entre medias de una sentencia que ocupa dos líneas.
    100_000_000.0;

declaración_tipo ::= type identificador is definición_tipo ;

-- Escalares discretos no estándar:
-- 
type TIndice is range 1..50;

-- Escalares reales no estándar:
-- 
type TPeso is digits 10;  -- Coma flotante con precisión de 10 cifras.
type TMasa is delta 0.01 range -12.0 .. 12.0; -- Coma fija 0.01 precis.

-- Enumeración:
-- 
type TColor is (ROJO, VERDE, AZUL);

-- Vectores:
-- 
type TMatriz is array (1..10, 1..10) of Float;
type TVector5 is array (TIndice range 5..10) of Float;

-- Registros:
-- 
type TVálvula is
  record
    Nombre: String(1..20);
    Abierta: Boolean;
    VelocidadLíquido: Float range 0.0 .. 30.0;
  end record;

-- Punteros:
-- 
type PEntero is access Integer;

-- Arrays irrestringidos. Tienen un número indefinido de
-- elementos. Es necesario especificar los límites al declarar
-- variables de ese tipo.
-- 
declare
  type TVectorIndef is array (Integer range <>) of Float;
   V: TVectorIndef (1..4);
begin
   V(1) := 10.28;
   V := (1.2, 1.5, 1.8, 1.3);
   V := (1 => 1.2, 2 => 1.7, others => 0.0);
end;

...
  type Color is (Rojo, Azul, Naranja);
  type Fruta is (Naranja, Pera, Melon);

  procedure Put (Una_Fruta : Fruta);
  procedure Put (Un_Color : Color);
...
begin

   Put (Color'(Naranja)); -- Llama a procedure Put (Un_Color : Color)
   Put (Fruta'(Naranja)); -- Llama a procedure Put(Una_Fruta : Fruta)
   Put (Naranja); -- Error de sintaxis, la llamada es ambigua
   Put (Rojo); -- Ok, llama a procedure Put (Un_Color : Color)
end;

type Índice is range 1 .. 50;

type Índice is range 1 .. 50;
for Índice'Size use 8;

with Ada.Text_IO;

procedure Range_1
is
  type Range_Type is range -5 .. 10;

  package T_IO renames Ada.Text_IO;
  package I_IO is new  Ada.Text_IO.Integer_IO (Range_Type);

begin
  for A in Range_Type loop
     I_IO.Put (
        Item  => A,
        Width => 3,
        Base  => 10);

     if A < Range_Type'Last then
        T_IO.Put (",");
     else
        T_IO.New_Line;
     end if;
  end loop;
end Range_1;

and
or
xor
type Nombre is mod Módulo;

type Byte is mod 256;
subtype Medio_Byte is Byte range 0 .. 127;

Medio_Byte
 type Color_Primario is (Rojo, Verde, Azul);

Color_Primario'Pos (Rojo) = 0
Color_Primario'Val (0)    = Rojo

type Luz_de_Tráfico is (Rojo, Ambar, Verde);

 type ABC is ('A', 'B', 'C');

type Mi_Caracter is (No_Caracter, 'a', Literal, 'z');
type Mi_String is array (Positive range <>) of Mi_Caracter;

S: Mi_String := "aa" & Literal & "za" & 'z';
T: Mi_String := ('a', 'a', Literal, 'z', 'a', 'z');

type Boolean is (False, True);

  subtype Letra_Mayúscula is Character range 'A' .. 'Z';
  subtype Color_Frío is Color_Primario range Verde .. Azul;

 digits Digitos

 digits Digitos range Primero .. Último

 delta Delta digits Digitos

 delta Delta digits Digitos range Primero .. Último

type T_Precio_en_Euros is delta 0.01 digits 15;

 delta Delta range Primero .. Último

type T_Medida is delta 0.125 range 0.0 .. 255.0;

array (Tipo_Índice) of Tipo_Elemento

type Contador_Caracteres is array (Character) of Natural;

subtype Subtipo_Índice is Tipo_Índice range Primero .. Último;

array (Subtipo_Índice) of Tipo_Elemento;

array (Tipo_Índice range Primero .. Último) of Tipo_Elemento;

array (Primero .. Último) of Tipo_Elemento

type Contador_Caracteres is array (Character range 'A' .. 'Z') of Natural;

array (Tipo_Índice range <>) of Tipo_Elemento

 type Día_De_Mes is range 1 .. 31;
 type Día_Con_Cita is array (Día_De_Mes) of Boolean;
 pragma Pack (Día_Con_Cita); 

 type  Día_De_Mes is range 1 .. 31;
 type Día_Con_Cita is array (Día_De_Mes) of aliased Boolean;

Vector_A (1 .. 3) := Vector_B (4 .. 6);

Nombre_Completo := Nombre & ' ' & Apellidos;

with Ada.Text_IO, Ada.Integer_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO;

procedure Agenda is

   type Dia_De_Mes is range 1 .. 31;
   type Dia_Con_Cita is array (Dia_De_Mes) of Boolean;
   Citas_En_Mayo : Dia_Con_Cita := (others => False); -- Se inicializa todo el mes a False
begin

   -- Tengo citas los dias 3, del 8 al 16 (excepto el 14), y el último día del mes.

   Citas_En_Mayo (3) := True;
   Citas_En_Mayo (8 .. 16) := (others => True);
   Citas_En_Mayo (14) := False;
   Citas_En_Mayo (Citas_En_Mayo'Last) := True;

   Put ("En mayo tienes citas los dias:");
   for I in Citas_En_Mayo'Range loop
      if Citas_En_Mayo (I) then
         Put (Dia_De_Mes'Image (I));
      end if;
   end loop;

end Agenda;

type String is array (Positive range <>) of Character;

Nombre : String (1 .. 8);  -- Explícitamente

Nombre : String := "Fulanito"; -- Implícitamente

 Nombre_Completo : constant String := Nombre & ' ' & Apellidos;

struct
record
type T_Sensor is
record
  Magnitud : Natural;
  Alarma   : Boolean;
end record;

procedure Medir_temperatura is
  Sensor_temperatura : T_Sensor;
begin
  Sensor_temperatura.Magnitud := 23;
  Sensor_temperatura.Alarma := False;
  -- ...
  if Sensor_temperatura.Alarma then
     Put_Line ("Alarma de temperatura");
  end if;
end;

procedure Asignar_temperatura is
  Sensor_temperatura : T_Sensor;
begin
  Sensor_temperatura :=
    (Magnitud => 23,
     Alarma   => False);
end;

type T_Sensor is
record
  Magnitud : Natural := 0;
  Alarma   : Boolean := False;
end record;

type Registro_Nulo
is record
   null;
end record; 

type Registro_Nulo is null record;

Nulo : constant Registro_Nulo := (null record);

type T_Matriz is array (Integer range <>, Integer range <>) of Float;
type T_Matriz_Cuadrada (Orden: Positive) is
  record
    Matriz: T_Matriz(1..Orden, 1..Orden);
  end record;

M: T_Matriz_Cuadrada(3);
-- También se puede emplear M: T_Matriz_Cuadrada(Orden => 3);
M := (3, (1..3 => (1..3 => 0.0)));
M := (M.Orden, (M.Matriz'Range(1) => (M.Matriz'Range(2) => 5.0)));
-- En la sentencia anterior M.orden ya está definido e igual a 3.

Max: constant := 100;
subtype T_Índice is Integer range 0..Max;
type T_Vector_Enteros is array (Integer range <>) of Integer;
type T_Polinomio (N: T_Índice := 0) is  -- Discriminante con valor inicial.
  record
    Pol: T_Vector_Enteros(0..N);
  end record;

P, Q: T_Polinomio;

P: T_Polinomio := (3, (5, 0, 4, 2));
R: T_Polinomio(5);  -- Aquí sólo se podrían usar polinomios de grado 5.

declare
  type TTipoVuelo is (MILITAR, CIVIL, ENEMIGO, DESCONOCIDO);
  type TRegistroVuelo (Clasif: TTipoVuelo) is
    record
      Velocidad: Float;
      Detalles: String(1..100);
      case Clasif is
        when CIVIL => null;
        when MILITAR => Origen, Destino: String(1..10);
        when ENEMIGO | DESCONOCIDO => NivelAmenaza: Integer;
      end case;
    end record;
  Vuelo1: TRegistroVuelo (MILITAR);
begin
  Vuelo1.Origen := "Francia   ";
end;

type PEntero is access Integer;

declare
  type TBúfer is
    record
      Mensaje: String(1..4);
      Prioridad: Integer;
    end record;
type PTBúfer is access TBúfer;
Mensaje1, Mensaje2: PTBúfer;
begin
  Mensaje1 := new TBúfer;  -- Se crea un objeto de tipo TBúfer.
  Mensaje2 := new TBúfer'(Prioridad => 2, Mensaje => "Hola");
  -- Con all se puede desreferenciar el puntero.
  -- Mensaje1 es un puntero y Mensaje1.all es el registro.
  Mensaje1.all.Prioridad := 3;
  -- Sin embargo, al acceder a campos del registro la desreferenciación
  -- puede hacerse implícita y .all es opcional en esos casos:
  Mensaje1.Prioridad := 3;

end;

declare
  -- TNodoÁrbolBinario se necesita para definir el puntero.
  type TNodoÁrbolBinario;  -- Se declara después.
  type PTNodoÁrbolBinario is access TNodoÁrbolBinario;
  type TNodoÁrbolBinario is
    record
      RamaIzda: PTNodoÁrbolBinario;
      Dato: Float;
      RamaDcha: PTNodoÁrbolBinario;
    end record;
   ÁrbolBinario: PTNodoÁrbolBinario;
begin
  -- Se crea la raíz del árbol binario.
  ÁrbolBinario := new TNodoÁrbolBinario'(null, 1.0, null);
end;

with Ada.Unchecked_Deallocation;

procedure Ejemplo_Liberar_Memoria is
  type TVector is array (Integer range <>) of Float;
  type PVector is access TVector;
  PV: PVector;
  procedure Liberar_Vector is new Ada.Unchecked_Deallocation
     (TVector, PVector);
begin
  PV := new TVector(1..10);
  PV.all := (others => 0.0);
  -- ...
  Liberar_Vector (PV); -- La memoria es liberada y PV es ahora null
end Ejemplo_Liberar_Memoria;

type TPCallback is access procedure (Id : Integer; Mensaje : String);

type TFCallback is access function (Mensaje : String) return Natural;

procedure ProcesarEvento (Id : Integer; Mensaje : String);

MiCallback : TPCallback := ProcesarEvento'Access;

type S is new T;

type TNumManzanas is new Integer;
NumManzanas: TNumManzanas;
-- ...
NumManzanas := NumManzanas + 1;

-- Supongamos que tenemos cajas en las que caben 20 piezas de frutas 
subtype TNumFrutas is Natural range 1 .. 20;
type TNumManzanas is new TNumFrutas;
type TNumPeras is new TNumFrutas;

NumManzanas: TNumManzanas;
NumPeras: TNumPeras;
NumFrutas: TNumFrutas;
-- ...

-- Error de compilación, no podemos juntar peras con manzanas:
NumManzanas := NumManzanas + NumPeras;  -- Ilegal

-- Pero siempre podemos contabilizarlos como frutas convirtiendo al tipo
-- base:
NumFrutas := TNumFrutas (NumManzanas) + TNumFrutas (NumPeras);

  type T_Base is tagged
    record
      ...
    end record;

type T_Base is tagged private;

 type T_Derivado is new T_Base with
   record
     ...
   end record;

 type T_Derivado is new T_Base with private;

subtype TDíaDelMes is Integer range 1..31;
subtype TDíaFebrero is TDíaDelMes range 1..29;
subtype TLaborable is TDíaDeSemana range Lunes..Viernes;

type TMatriz is array (Positive range <>, Positive range <>) of Integer;
subtype TMatriz10x10 is TMatriz (1 .. 10, 1 .. 10);  

type TPersona (Sexo : TSexo) is
  record
    Nombre : TNombre;
    case Sexo is
      when Mujer => Embarazada : Boolean;
      when Hombre => null;
    end case;
  end record;

subtype TMujer is TPersona (Sexo => Mujer);

declaración_variable ::= identificador { , identificador } : tipo
  [ := expresión ] ;

V: Boolean := TRUE;
I, J: Integer := 1;
Nombre: String := "Wikilibros";
Destino_A_Calcular: Coordenadas;

declaración_constante ::= identificador { , identificador } : constant
  [ tipo] [ := expresión ] ;

PI: constant Float := 3.14159_26536;

OtroPI: constant := 3.14;  -- En este caso es de tipo universal_float.

Entidad'Atributo

Tipo'Atributo(Entidad)

type Tipo_enumerado is (Enum1, Enum2, Enum3);
for Tipo_enumerado'Size use 2; -- Para representar 3 unidades necesitamos 2 bits

type Tipo_entero  is range -1 .. 5;

... 

pragma Assert (Tipo_enumerado'Last = Enum3);  -- Correcto
pragma Assert (Tipo_entero'First  = -1);      -- Correcto
pragma Assert (Tipo_entero'Last  = 4);        -- ¡¡Incorrecto!!

pragma Assert (Tipo_enumerado'Pred( Enum2 ) = Enum1);      -- Correcto
pragma Assert (Tipo_enumerado'Succ( Enum2 ) = Enum3);      -- Correcto
pragma Assert (Tipo_enumerado'Image( Enum1 ) = "Enum1");   -- Correcto

 type Tipo_flotante is digits 10 range 0.0..100.0; -- 10 cifras decimales en la mantisa

Var_Flotante  : Float := 1.5;
Var_Flotante2 : Float := 1.9;
Var_Flotante3 : Float := 1.0;
Var_Flotante4 : Float := -1.8;
Var_Flotante5 : Float := 1.1;
...
pragma Assert (Float'Ceiling(var_Flotante)  = 2.0);  -- Correcto
pragma Assert (Float'Ceiling(var_Flotante2) = 2.0);  -- Correcto
pragma Assert (Float'Ceiling(var_Flotante3) = 1.0);  -- Correcto
pragma Assert (Float'Ceiling(var_Flotante3) = 2.0);  -- ¡¡Incorrecto!!

pragma Assert (Float'Truncation(var_Flotante) = 1.0);  -- Correcto
pragma Assert (Float'Truncation(var_Flotante2) = 1.0);  -- Correcto
pragma Assert (Float'Truncation(var_Flotante3) = 1.0);  -- Correcto
pragma Assert (Float'Truncation(var_Flotante4) = -1.0);  -- Correcto

pragma Assert (Float'Rounding(var_Flotante5)  = 1.0);  -- Correcto
pragma Assert (Float'Rounding(var_Flotante)  = 2.0);  -- Correcto

A : Character := Character'Val (32) -- A toma el valor de espacio (valor 32 en la tabla ASCII)
B : Character := ' ';               -- B también toma el valor de espacio

Resultado : Natural;
...
if not Resultado'Valid then
  -- 'Resultado' está fuera del rango, con valor negativo
  Result := Natural'First;
end if

expresión ::= relación operador relación
relación ::= expresión_simple [ operador_relacional expresión_simple ]
  | expresión_simple [ not ] in rango
expresión_simple ::= [ operador_unario ] término
  { operador_binario término }

and
or
xor
=
/=
<
<=
>
>=
+
-
+
-
&
*
/
mod
rem
**
not
abs
in
not
in
-- Supongamos que X es de tipo Integer
if X in Positive then -- Positive es un subtipo de Integer
   ...
   if X not in 4 .. 6 then
      ...
   end if;
end if;

declare
   type Dia_Semana is
      (Lunes, Martes, Miercoles, Jueves, Viernes, Sabado, Domingo);
   subtype Dia_Laborable is Dia_Semana range Lunes .. Viernes;
   Hoy : Dia_Semana := Obtener_Dia;
begin

   if Hoy in Dia_Laborable then -- Dia_Laborable es un subtipo de Dia_Semana
      Ir_Al_Trabajo;
      if Hoy not in Lunes .. Miercoles then
         Pensar_En_El_Fin_De_Semana;
      end if;
   end if;
end;

and then
or else
-- B / A > 3 no se ejecutará si A es 0 lo que nos será útil para evitar
-- un Constraint_Error
-- 
if A /= 0 and then
   B / A > 3 then

   Put_Line ("B / A es mayor que 3");

end if;

X := Y;
bloque ::=
  [ identificador : ]
  [ declare
    parte_declarativa ]
  begin
    sentencias
  [ exception
    manejador_de_excepción
    { manejador_de_excepción } ]
  end [ identificador ] ;

-- Supuestas X e Y declaradas con anterioridad de tipo Float:
declare
  Temp: Float;  -- Esta variable solo es visible dentro del bloque.
begin  -- Se intercambian 2 variables.
  Temp := X;
  X := Y;
  Y := Temp;
end;

sentencia_selección ::=
  if condición then secuencia_de_sentencias
  [ { elsif condición then secuencia_de_sentencias } ]
  [ else secuencia_de_sentencias ]
  end if ;

with Ada.Text_Io,Ada.Integer_Text_Io;
use Ada.Text_Io,Ada.Integer_Text_Io;

procedure comptar_LA is
  cp,c: character;
  n: integer;  --declaramos las variables
begin
  Put("Escribe una frase");  --pedimos y recogemos texto
  Put(c);
  n := 0;   --inicializamos n a cero
  cp := ' ';
  get(c); --si cp es espacio seguir leyendo
  while c /= '.' loop  --mientras c sea diferente del PUNTO, entrar en bucle
    if cp = 'L' and c = 'A' then     
       n := n+1;
    end if; -- si cp es L y c es A incrementar n y finalizar el if
    cp := c; 
    Get(c); --igualamos cp a c para proceder y c sigue al próximo caracter
  end loop; --FINALIZAMOS BUCLE
  Put("El numero de palabras de la frase es"); --enseñamos en pantalla la variable n
  Put(n);
end comptar_LA;

if Hoy = DOM then  -- Si hoy es domingo.
  Mañana := LUN;
elsif Hoy /= SAB then  -- Si no es domingo ni sábado.
  Laborable := True;
else  -- Cualquier otro caso.
  Mañana := TDía'Succ(Hoy);
end if;

sentencia_selección_por_casos ::=
  case expresión is
    alternativa_caso { alternativa_caso }
  end case ;

alternativa_caso ::=
  when elección { | elección } => secuencia_de_sentencias
elección ::= expresión_simple | rango_discreto | others

case Hoy is
  when MIE..VIE => Entrenar_duro;  -- Rango.
  when MAR | SAB => Entrenar_poco;  -- Varias elecciones.
  when DOM => Competir;  -- Una elección.
  when others => Descansar;  -- Debe ser única y la última alternativa.
end case;

sentencia_bucle_simple ::=
  [ identificador_bucle : ] loop
    secuencia_de_sentencias
  end loop [ identificador_bucle ] ;

Vida: loop  -- El bucle dura indefinidamente.
  Trabajar;
  Comer;
  Dormir;
end loop Vida;

loop
  Alimentar_Caldera;
  Monitorizar_Sensor;
  exit when Temperatura_Ideal;
end loop;

sentencia_bucle_iterativo ::=
  [ identificador_bucle : ] for parámetros_for loop
    secuencia_de_sentencias
  end loop [ identificador_bucle ] ;

parámetros_for ::= identificador in [ reverse ] rango_discreto

for I in 1..N loop  -- I se itera desde 1 hasta N.
  V(I) := 0;
end loop;

procedure bloque_para_inverso is
   i : Integer;
begin
   i := 0;
   for i in reverse 1..10 loop
       Put(i, 0);
       Put(" ");
   end loop;
end bloque_para_inverso;

procedure bloque_para_inverso is
   i : Integer;
begin
   i := 0;
   for i in 0..5 loop
       Put(i*2, 0);
       Put(" ");
   end loop;
end bloque_para_inverso;

sentencia_bucle_iterativo ::=
  [ identificador_bucle : ] while condición loop
    secuencia_de_sentencias
  end loop [ identificador_bucle ] ;

I := 1;
while I > N loop  -- Se hace el bucle mientras se cumpla la condición.
  V(I) := 0;
  I := I + 1;
end loop;

<<
>>
<<Salto>>
sentencia_exit ::= exit [ nombre_bucle ] [ when condición ] ;

sentencia_return ::= return [ expresión ] ;

sentencia_abort ::= abort nombre_tarea { , nombre_tarea } ;

especificación_procedimiento ::=
  procedure identificador
    [ ( especificación_parámetro { ; especificación_parámetro } ) ]

especificación_parámetro ::= identificador { , identificador } : [ modo ] tipo
  [ := expresión ]
modo ::= in | out | in out

cuerpo_procedimiento ::=
  especificación_procedimiento is
    [ parte_declarativa ]
  begin
    secuencia_de_sentencias
  [ exception
    manejador_de_excepción { manejador_de_excepción } ]
  end [ identificador ] ;

procedure Una_Prueba (A, B: in Integer; C: out Integer) is
begin
 C:= A + B;
end Una_Prueba;

with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;

procedure Ecuación_Cuadrática
   (A, B, C : Float;  -- Por defecto es in.
    R1, R2  : out Float;
    Válida  : out Boolean) is
  Z: Float;
begin
  Z := B * B - 4.0 * A * C;
  if Z < 0.0 or A = 0.0 then
    Válida := False;
    -- Al ser de salida, se tienen que modificar al menos una vez.
    R1 := 0.0;
    R2 := 0.0;
  else
    Válida := True;
    R1 := (-B + SQRT (Z)) / (2.0*A);
    R2 := (-B - SQRT (Z)) / (2.0*A);
  end if;
end Ecuación_Cuadrática;

especificación_función ::=
  function ( identificador | símbolo_operador )
    [ ( especificación_parámetro { ; especificación parámetro } ) ]
  return tipo

especificación_parámetro ::= identificador { , identificador } : [ in ] tipo
  [ := expresión ]

cuerpo_función ::=
  especificación_función is
    [ parte_declarativa ]
  begin
    secuencia_de_sentencias
  [ exception
    manejador_de_excepción { manejador_de_excepción } ]
  end [ identificador | símbolo_operador ] ;

function Mínimo (A, B: Integer) return Integer is
begin
  if A > B then return B;
  else return A;
  end if;
end Mínimo;

function Factorial (N: Positive) return Positive is
begin
  if N = 1 then
    return 1;
  else
    return (N * Factorial (N - 1));
  end if;
end Factorial;

type TVector is array (Positive range <>) of Float;
function Suma_Componentes (V: TVector) return Float is
  Resultado: Float := 0.0;
begin
  for I in V'Range loop
    Resultado := Resultado + V(I);
  end loop;
  return Resultado;
end Suma_Componentes;

V4: TVector(1..4) := (1.2, 3.4, 5.6, 7.8);
Suma: Float;
Suma := Suma_Componentes (V4);

function Invierte_Componentes (V: TVector) return TVector is
  Resultado: TVector(V'Range);  -- Fija el límite del vector a devolver.
begin
  for I in V'Range loop
    Resultado(I) := V(V'First + V'Last - I);
  end loop;
  return Resultado;
end Invierte_Componentes;

Ecuación_Cuadrática (Válida => OK, A => 1.0, B => 2.0, C => 3.0,
  R1 => P, R2 => Q);
F := Factorial (N => (3 + I));

procedure Prueba_Por_Defecto (A : in Integer := 0; B: in Integer := 0);

Prueba_Por_Defecto (5, 7);  -- A = 5, B = 7
Prueba_Por_Defecto (5);  -- A = 5, B = 0
Prueba_Por_Defecto;  -- A = 0, B = 0
Prueba_Por_Defecto (B => 3);  -- A = 0, B = 3
Prueba_Por_Defecto (1, B => 2);  -- A = 1, B = 2

declare
   type TColor is (ROJO, VERDE, AZUL);
   type TLuz is (ROJO, AMARILLO, VERDE);
   Pixel: TColor;
   Indicador: TLuz := VERDE;
begin
   -- Se emplea calificador para distinguir.
   Pixel := TColor'(VERDE);
end;

function "*" (A, B: Vector) return Float is
  Resultado: Float := 0.0;
begin
  for I in A'range loop
    Resultado := Resultado + A(I) * B(I);
  end loop;
  return Resultado;
end "*";

declare
  type TAlimento is (PAN, LECHE, ACEITE);
  type TProducto_Automóvil is (ACEITE, BUJÍA);
  procedure Comprar (ProdAlim: TAlimento) is  -- ...
  procedure Comprar (ProdAutom: TProducto_Automóvil) is  -- ...
begin
  Comprar (ACEITE);  -- Ambigüedad.
  Comprar (TAlimento'(ACEITE));  -- Se supera la ambigüedad.
  Comprar (ProdAlim => ACEITE);  -- También se supera la ambigüedad.
end;

-- Ejemplo para limpiar la pantalla

with Interfaces.C;

procedure Cls is

  package C renames Interfaces.C;

  function System (Command : C.Char_Array) return C.Int;
  pragma Import(C, System, "system");

  Rc : C.Int;
begin
   Rc := System (C.To_C ("cls")); -- Comando sintaxis MS-DOS. En Unix sería clear
end Cls;

gnatmake cls.adb

gcc -c mis_funciones.c

gnatmake ejemplo.adb -largs mis_funciones.o

 type Estado_T is (Desconectado, Conectado, Desconocido);
 -- Especificamos que el compilador ha de usar dos bits
 for Estado_T'Size use 2;
 -- Especificamos los valores que se usarán en memoria para cada valor
 for Estado_T use (Desconectado => 0, Conectado => 1, Desconocido => 3);

 type Estructura_Estado_T is
   record
     Estado            : Estado_T;
     Numero_Reintentos : Integer;
   end record;

 for Estructura_Estado_T use
   record
      Estado            at 0 range 0 .. 2; -- Primer y 2º bit de la 1ª palabra
      Numero_Reintentos at 1 range 0 .. 31; -- 32 bits en la 2ª palabra
   end record;

 type Array_Bits_T is array (Positive range <>) of Boolean;

 -- Indicamos que se use un único bit para el tipo Boolean (dos valores, un
 -- bit es suficiente) y de este modo tenemos un array de bits sobre el 
 -- que podemos aplicar operadores booleanos:
 pragma Pack (Array_Bits_T);

especificación_paquete ::=
  package [ identificador_unidad_padre . ] identificador is
    { declaración_básica }
  [ private  { declaración_básica } ]
  end [ [ identificador_unidad_padre . ] identificador ] ;

cuerpo_paquete ::=
  package body [ identificador_unidad_padre . ] identificador is
    [ parte_declarativa ]
  [ begin
    secuencia_de_sentencias
  [ exception
    manejador_de_excepción
    { manejador_de_excepción } ] ]
  end [ [ identificador_unidad_padre . ] identificador ] ;

package Pila_Enteros is  -- Especificación.
  procedure Poner (Elem: Integer);  -- Interfaz.
  function Quitar return Integer;   -- Interfaz.
end Pila_Enteros;

package body Pila_Enteros is  -- Cuerpo.
  Max : constant := 100;           -- Se ocultan las variables locales.
  Pila: array (1..Max) of Integer;  -- Se ocultan las variables locales.
  Cima: Integer range 0..Max;      -- Se ocultan las variables locales.

  procedure Poner (Elem: Integer) is  -- Implementación.
  begin
    Cima := Cima + 1;
    Pila (Cima) := Elem;
  end Poner;

  function Quitar return Integer is  -- Implementación.
  begin
    Cima := Cima - 1;
    return Pila(Cima + 1);
  end Quitar;

begin
  Cima := 0;  -- Inicialización.
end Pila_Enteros;

package Sobre_Dias is
  type TDia is (LUN, MAR, MIE, JUE, VIE, SAB, DOM);
  subtype TDiaLaborable is TDia range LUN..VIE;
  SiguenteDia: constant array (TDia) of TDia :=
    (MAR, MIE, JUE, VIE, SAB, DOM, LUN);
end Sobre_Días;

declare
  N: Integer;
  package Pila_Enteros is
    -- ...
  end Pila_Enteros;
begin
  Pila_Enteros.Poner (15);
  N := Pila_Enteros.Quitar;
end;

cláusula_use_paquete ::= use identificador { , identificador } ;

-- ...
declare
  use Pila_Enteros;
  N: Integer;
begin
  Poner (15);
  N := Quitar;
end;

package P1 is
  package P2 is
    -- ...
  end P2;
  -- ...
end P2;

use P1, P1.P2;  -- Ilegal sería "use P2;"

cláusula_with ::= with identificador { , identificador } ;

with Pila_Enteros;  -- Se hace visible el paquete para todo el programa.
procedure Prueba_Pila_Enteros is
  use Pila_Enteros;  -- Para no usar nombre del paquete en las llamadas.
  N: Integer;
begin
  Poner (15);
  N := Quitar;
end Prueba_Pila_Enteros;

procedure P;    -- Declaración de P, necesaria para utilizara en Q.
procedure Q is  -- Cuerpo de Q.
begin
  P;
  -- ...
end Q;
procedure P is  -- Repite especificación para declarar el cuerpo.
begin
  Q;
  -- ...
end P;

procedure P is
  -- ///////////////////////////////////// Parte declarativa de P.
  -- ...
  -- -------------------------------------- Ámbito de A.
  A: Float;
  -- -------------------------------------- Ámbito de Q.
  -- ////////////// Región declarativa de I y R.
  procedure Q is
  -- /////////////////////////////// Parte declarativa de Q.
    -- ------------------------------ Ámbito de I.
    I: Integer := 0;
    -- ...
    -- //////// Región declarativa de J.
    package R is
      -- ///////// Parte declarativa pública de R.
      -- --------------------- Ámbito de J.
      J: Integer := I;
      -- ...
      -- ///// Fin parte declarativa pública de R.
    end R;
    package body R is
      -- ///////// Parte declarativa privada de R.
      -- --------------------- Ámbito de K
      K: Integer := I + J;
      -- ...
      -- ///// Fin parte declarativa privada de R.
    begin
      -- ...
    end R;
      -- ----------------- Fin ámbito de K
      -- ----------------- Fin ámbito de J.
    -- //// Fin región declarativa de J.
  -- /////////////////////////// Fin parte declarativa de Q.
  begin
    -- ...
  end Q;
  -- ...
    -- -------------------------- Fin ámbito de I.
  -- ////////// Fin región declarativa de I y R.
  -- ///////////////////////////////// Fin parte declarativa de P.
begin
  -- ...
end P;
  -- ---------------------------------- Fin ámbito de A.
  -- ---------------------------------- Fin ámbito de Q.

I: Integer := I +1;
declare
  -- Ámbito de I externa.
  I, J: Integer;
  -- Visibilidad de I externa.
begin
  -- ...
  declare
    -- Ámbito de I interna.
    I: Integer := 0;
    -- Visibilidad de I interna, oculta la visibilidad de I externa.
  begin
    -- ...
  end;
    -- Fin visibilidad de I interna, oculta la visibilidad de I externa.
    -- Fin ámbito de I interna.
end;
  -- Fin visibilidad de I externa.
  -- Fin ámbito de I externa.

Externo: declare
  I, J: Integer;  -- I externa.
begin
  -- ...
  declare
    I, K: Integer;  -- I interna.
  begin
    K := J + Externo.I;  -- Se hace referencia a la I externa.
  end;
end Externo;

renames
function "*" (X, Y: TVector) return Float renames ProductoEscalar;

procedure Poner (Elem: Integer) renames PilaEnteros.Poner;

F: TFecha renames Agenda(I).FechaNacimiento;
------
package P renames Plantilla_Pila;

package Servidor is
  type Petición_T is private;
  -- ...
end Servidor;

package Servidor.Sesión is

  type Sesión_T is
  record
    Petición : Petición_T; -- Equivalente a Servidor.Petición_T
    -- ...
  end record;
  -- ...
end Servidor.Sesión;

package body Pila_Enteros is  -- Cuerpo.
  Max : constant := 100;
  Pila: array(1..Max) of Integer;
  Cima: Integer range 0..Max;
  procedure Poner (Elem: Integer) is separate;  -- Se compila aparte.
  function Quitar return Integer is separate;  -- Se compila aparte.
begin
  Cima := 0;  -- Inicialización.
end Pila_Enteros;

separate (Pila_enteros)  -- Indica la unidad de la que se extrajo.
  procedure Poner (Elem: Integer) is
  begin
    Cima := Cima + 1;
    Pila (Cima) := Elem;
  end Poner;

package Números_complejos is
  type TComplejo is
    record
      Real, Imag: Float;
    end record;
  I: constant TComplejo := (0.0, 1.0);
  function "+" (X, Y: TComplejo) return TComplejo;
  function "-" (X, Y: TComplejo) return TComplejo;
  function "*" (X, Y: TComplejo) return TComplejo;
  function "/" (X, Y: TComplejo) return TComplejo;
end Números_complejos;

package Números_complejos is
  -- Parte visible.
  type TComplejo is private;  -- Tipo privado.
  I: constant TComplejo;  -- No se puede asignar valor todavía.
  function "+" (X, Y: TComplejo) return TComplejo;
  function "-" (X, Y: TComplejo) return TComplejo;
  function "*" (X, Y: TComplejo) return TComplejo;
  function "/" (X, Y: TComplejo) return TComplejo;
  function Construir_complejo (R, I: Float) return TComplejo;
  function Parte_imaginaria (X: TComplejo) return Float;
  function Parte_real (X: TComplejo) return Float;
private
  -- Parte oculta.
  type TComplejo is
    record
      Real, Imag: Float;
    end record;
  I: constant TComplejo := (0.0, 1.0);
end Números_complejos;

package body Números_complejos is
  function "+" (X, Y: Tcomplejo) return TComplejo is
  begin
    return (X.Real + Y.Real, X.Imag + Y.Imag);
  end "+";
  -- ... "-", "* y "/" similarmente.
  function Construir_complejo (R, I: Float) return TComplejo is
  begin
    return (R, I);
  end Construir_complejo;
  function Parte_real (X: TComplejo) return Float is
  begin
    return X.Real;
  end Parte_real;
  -- ... Parte_imaginaria análogamente.
end Números_complejos;

declare
  use Números_complejos;
  C1, C2: TComplejo;
  R1, R2: Float;
begin
  C1 := Construir_complejo (1.5, -6.0);
  C2 := C1 + I;
  R := Parte_real (C2) + 8.0;
end;

-- ...
private
  Pi: constant := 3.1416;
  type TComplejo is
    record
      R: Float;
      Theta: Float range 0.0 .. 2*Pi;
    end recod;
  I: constant TComplejo := (1.0, 0.5*Pi);
end Números_complejos;

limited private
package Pilas is
  type TPila is limited private;  -- Tipo privado limitado.
  procedure Poner (P: in out TPila; X: in Integer);
  procedure Quitar (P: in out TPila; X: out Integer);
  function "=" (P1, P2: TPila) return Boolean;
private
  Max: constant := 100;
  type TVectorEnteros is array (Integer range <>) of Integer;
  type TPila is
    record
      P: TVectorEnteros(1..Max);
      Cima; Integer range 0..Max := 0;
    end record;
end Pilas;

unidad_genérica ::=
  generic
    { lista_parámetros_genéricos }
  ( especificación_subprograma | especficicación_paquete )
lista_parámetros_genéricos ::=
  identificador { , identificador } [ in [ out ] ] tipo [ := expresión ] ;
  | type identificador is  ( (<>) | range <> | digits <> | delta <>
    | definición_vector | definición_puntero )
  | declaración_privada_de_tipo
  | declaración_formal_procedimiento
  | declaración_formal_paquete

generic
  type TElemento is private;  -- Parámetro tipo formal genérico.
procedure Intercambiar (X, Y: in out TElemento);

procedure Intercambiar (X, Y: in out TElemento) is
  Temporal : TElemento;
begin
  Temporal := X;
  X := Y;
  Y := Temporal;
end Intercambiar;

instanciación_unidad_genérica ::=
  ( package | procedure | function ) identificador is new
    identificador [ ( parámetro_instanciado { , parámetro_instanciado } ) ] ;

procedure Intercambiar_enteros is new Intercambiar (Integer);

procedure Inter is new Intercambiar (Float);
procedure Inter is new Intercambiar (TDía);
procedure Inter is new Intercambiar (TElemento => TPila);

generic  -- Especificación unidad genérica.
  Max: Positive;  -- Parámetro bjeto formal genérico.
  type TElemento is private;  -- Parámetro tipo formal genérico.
package Plantilla_pila is
  procedure Poner (E: TElemento);
  function Quitar return TElemento;
end Plantilla_pila;

package body Plantilla_pila is  -- Cuerpo unidad genérica.
  Pila: array(1..Max) of TElemento;
  Cima: Integer range 0..Max;
  -- ...
end Plantilla_pila;

declare
  package Pila_reales_de_100 is new Plantilla_pila (100, Float);
  use Pila_reales_de_100;
begin
  Poner (45.8);
  -- ...
end;

generic
  type TElem is private;
  with function "*" (X, Y: TElem) return TElem;
function cuadrado (X : TElem) return TElem;

function cuadrado (X: TElem) return TElem is
begin
  return X * X;  -- El operador "*" formal.
end cuadrado;

with Cuadrado;
with Matrices;
procedure Prueba_operaciones is
  function Cuadrado_matriz is new Cuadrado
    (TElem => Matrices.TMatriz, "*" => Matrices.Producto_matrices);
  A: TMatriz := TMatriz.Identidad;
begin
  A := Cuadrado_matriz (A);
end Prueba_operaciones;

manejador_excepción ::=
  when [ identificador : ] elección_excepción { | elección_excepción } =>
    secuencia_sentencias
elección_excepción ::= identificador | others

begin
  -- ...
exception
  when Constraint_Error =>
    Put ("Error de rango.");
  when Program_Error | Tasking_Error =>
    Put ("Error de flujo.");
  when others =>
    Put ("Otro error.");
end;

function Mañana (Hoy: TDía) return TDía is
begin
  return TDía'Succ(Hoy);
exception
  when Constraint_Error =>
    return TDía'First;
end Mañana;

Error: exception;

elevación_excepción ::= raise [ identificador ] ;

package Pila_enteros is
  ErrorPilaEnteros: exception;
  procedure Poner (X: Integer);
  function Quitar return Integer;
end Pila_enteros;

package body Pila_enteros is
  Max: constant := 100;
  Pila: array (1..Max) of Integer;
  Cima: Integer range 0..Max;

  procedure Poner (X: Integer) is
  begin
    if Cima = Max then
      raise ErrorPilaEnteros;  -- Se eleva la excepción.
    end if;
    Cima := Cima + 1;
    P(Cima) := X;
  end Poner;

 function Quitar return Integer is
 begin
   if Cima = 0 then
     raise ErrorPilaEnteros;  -- Se eleva la excepción.
   end if;
   Cima := Cima - 1;
   return Pila(Cima+1);
 end Quitar;

begin
  Cima := 0;
end Pila_enteros;

declare
  use Pila_enteros;
begin
  Poner (5);
  -- ...
exception
  when ErrorPilaEnteros =>
    -- ... Manipulación incorrecta de la pila.
  when others =>
    -- ...
end;

procedure Vaciar_pila_enteros is
  Basura: Integer;
  use Pila_enteros;
begin
  loop
    Basura := Quitar;
  end loop;
exception
  when ErrorPilaEnteros =>
    null;
end Vaciar_pila_enteros;

-- ...
exception
  when ErrorPilaEnteros =>
    Put ("Pila utilizada incorrectamente.");
    Vaciar_pila_enteros;
    raise ErrorProcesamieto;  -- Se propaga otra excepción.
end;

-- ...
exception
  when FalloEnVálvula =>
    Put ("Se ha producido un fallo en la válvula.");
    raise;  -- Se propaga la misma excepción del manejador.
end;

when Ocurrencia : ErrorSensor =>
   Put_Line (Ada.Exceptions.Exception_Information (Ocurrencia));

especificación_tarea ::=
  task identificador [ is
    { punto_entrada_tarea | cláusula_representación }
  [ private { punto_entrada_tarea | cláusula_representación } ]
  end [ identificador ] ] ;
punto_entrada_tarea ::=
  entry identificador [ ( tipo | rango ) ] [ ( parámetro { , parámetro } ) ] ;

cuerpo_tarea ::=
  task body identificador is
    [ parte_declarativa ]
  begin
    secuencia_de_sentencias
  end [ identificador ] ;

with Ada.Text_IO; use Ada.Text_IO;

procedure Tareas_tontas is

  task Tarea1;
  task Tarea2;

  task body Tarea1 is
  begin
    loop
      Put ("Soy la tarea 1.");
    end loop;
  end Tarea1;

  task body Tarea2 is
  begin
    loop
      Put ("Soy la tarea 2.");
    end loop;
  end Tarea2;

begin
  -- En este momento comienzan a ejecutarse ambas tareas.
  Put ("Soy el procedimiento principal.");
end Tareas_tontas;

with Paquete_control_temperatura; use Paquete_control_temperatura;
with Paquete_control_presión; use Paquete_control_presión;

procedure Control_temperatura_y_presión

  task Control_temperatura;
  task Control_presión;

  task body Control_temperatura is
    Temperatura: TTemperatura;
    Temperatura_referencia: TTemperatura := 55;
    AcciónCalefactor: TAcciónCalefactor;
  begin
    loop
      Temperatura := Leer;
      AccciónCalefactor := Control (Temperatura, Temp_referencia);
      Escribir (AcciónCalefactor);
      delay (2.0);
    end loop;
  end Control_temperatura;

  task body Control_presión is
    Presión: TPresión;
    Presión_referencia: TPresión := 315;
    PosiciónValvula: TPosiciónVálvula;
  begin
    loop
      Presión := Leer;
      PosiciónVálvula := Control (Presión, Presión_referencia);
      Escribir (PosiciónVálvula);
      delay (3.0);
    end loop;
  end Control_presión;

begin
  -- Comienzan a ejecutarse Control_temperatura y Control_presión;
  null; -- Un cuerpo de procedimiento no puede estar vacío.
end Control_temperatura_y_presión;

task Tarea is
  entry Entrada (N: Integer);
end Tarea;

T: Tarea;
-- ...
T.Entrada (8);

type TNivel is Integer range 1..10;
task Controlador is
  -- Se define un punto de entrada por cada nivel.
  entry Aviso (TNivel) (Elem: TElemento);
end Controlador;

ProcesoColtrol: Controlador;
-- ...
ProcesoControl.Aviso (3) (1773);

acceptación_cita ::=
  accept identificador [ ( expresión ) ]
    [ ( especificación_parámetro { ; especificación parámetro } ) ] [ do
    secuencia_de_sentencias
  end [ identificador ] ] ;

accept Entrada (N: Integer) do
  -- ... Secuencia de sentencias.
end Entrada;

task Simple is
  entry Continuar;
end Simple;
task body Simple is
begin
  -- ...
  accept Continuar;  -- Se queda bloqueado hasta que se cite.
  -- ...  
end Simple;

task Buffer1 is
  entry Escribir (Elem: TElemento);
  entry Leer (Elem: out TElemento);
end Buffer1;
task body Buffer1 is
  ElemLocal: TElemento;
begin
  loop
    accept Escribir (Elem: TElemento) do
      ElemLocal:= Elem;  -- Guarda el elemento.
    end Escribir;
    Ada.Text_IO.Put_Line("Elemento escrito, voy a intentar LEER!");
    accept Leer (Elem: out TElemento) do
      Elem := ElemLocal;  -- Devuelve el elemento.
    end Leer;
    Ada.Text_IO.Put_Line("Elemento leido, vuelvo a intentar ESCRIBIR");
  end loop;
end Buffer1;

accept Aviso (3) (Elem: Telemento) do
  -- ...
end Aviso;

seleccción_aceptación_cita ::=
  select
    [ when condición => ]
      ( acceptación_cita | ( delay [ until ] expresión )
      [ secuencia_de_sentencias ] )
      | ( terminate ; ) )
  { or
    [ when condición => ]
      ( acceptación_cita | ( delay [ until ] expresión )
      [ secuencia_de_sentencias ] )
      | ( terminate ; ) ) }
  [ else
    sequencia_sentencias ]
  end select ;

task Servidor is
  entry Trabajar;
  entry Cerrar;
end;
task body Servidor is
begin
  loop
    select
      accept Trabajar do  -- Se acepta la llamada a trabajar.
        Trabajando := True;  -- Variable global.
      end;
      Trabajo_servidor;  -- Trabaja.
    or
      accept Cerrar;  -- Se cierra el servidor.
      exit;
    or
      delay (60.0);  -- ¿Se han olvidado del servidor?
      Put ("Estoy esperando trabajar.");
-- Otra opción en vez de delay:
-- or
--      --Terminación normal cuando se destruya el objeto tarea.
-- terminate;
    end select;
  end loop;
end Servidor;

task Variable_protegida is
  entry Leer (Elem: out TElemento);
  entry Escribir (Elem: TElemento);
end;
task body Variable_protegida is
  ElemLocal: TElemento;
begin
  accept Escribir (Elem: TElemento) do
    ElemLocal := Elem;
  end Escribir;
  loop
    select
      accept Escribir (Elem: TElemento) do
        ElemLocal := Elem;
      end Escribir;
    or
      accept Leer (Elem: out TElemento) do
        Elem := ElemLocal;
      end Leer;
    end select;
  end loop;
end Variable_protegida;

llamada_a_punto_de_entrada_compleja ::=
  llamada_a_punto_de_entrada_con_tiempo_límite
  | llamada_a_punto_de_entrada_condicional
  | llamada_a_punto_de_entrada_asíncrona

llamada_a_punto_de_entrada_con_tiempo_límite ::=
  select
    identif_p_entrada [ ( tipo | rango ) ] [ ( parámetro { , parámetro } ) ] ;
    [ secuencia_de_sentencias ]
  or
    delay [ until ] expresión ;
    [ secuencia_de_sentencias ]
  end select ;

llamada_a_punto_de_entrada_condicional ::=
  select
    identif_p_entrada [ ( tipo | rango ) ] [ ( parámetro { , parámetro } ) ] ;
    [ secuencia_de_sentencias ]
  else
    secuencia_de_sentencias
  end select ;

llamada_a_punto_de_entrada_asíncrona ::=
select
  ( identif_p_entrada [ ( tipo | rango ) ] [ ( parámetro { , parámetro } ) ] ; )
  | ( delay [ until ] expresión ; )
  [ secuencia_de_sentencias ]
then abort
  secuencia_de_sentencias
end select ;

select
  Controlador.Petición (Medio) (Elem);
or
  delay 50.0;
  Put ("Controlador demasiado ocupado.");
end select;

select
  Procesado.Aviso;
else
  raise Error;
end select;

select
  delay 5.0;
  raise FunciónNoConverge;
then abort
  Función_recursiva (X, Y);
end select;

declaración_tipo_tarea ::=
  task type identificador [ ( discriminante { ; discriminante } ) ] [ is
    { punto_entrada_tarea | cláusula_representación }
  [ private { punto_entrada_tarea | cláusula_representación } ]
  end [ identificador ] ] ;
discriminante ::=
  identificador { , identificador } : [ access ] subtipo [ := expresión ]

declare
  task type TTareaA;
  task type TTareaB;
  task type TTareasMúltiples;
  type TVectorTareas is array (1..10) of TTareasMúltiples;
  A: TTareaA;
  B: TTareaB;
  V: TVectorTareas;
  task body TTareaA is
    -- ...
  end;
  task body TTareaB is
    -- ...
  end;
  task body TTareasMúltiples is
    -- ...
  end;
begin  -- A partir de aquí se ejecutan las 12 tareas concurrentemente.
  -- ...
end;

procedure Ejemplo_tareas_dinámicas is
  task type TTarea;
  type PTTarea is access TTarea;
  T1: PTTarea;
  T2: PTTarea := new TTarea;  -- Se crea la tarea T2.all.
begin
  T1 := new TTarea;  -- Se crea la tarea T1.all.
  T1 := null;  -- Se pierde la referencia, pero se sigue ejecutando.
  -- ...
end Ejemplo_tareas_dinámicas;

task type TManejadorTeclado (ID: TIDentifTeclado := IDPorDefecto) is
  entry Leer (C: out Character);
  entry Escribir (C: in  Character);
end TManejadorTeclado;
type PTManejadorTeclado is access TManejadorTeclado;
Terminal: PTManejadorTeclado := new TManejadorTeclado (104);

declare
  task type TTarea;
  type PTTareaGlobal is access TTarea;
  T1, T2: TTarea;
  PunteroTareaGlobal1: PTTareaGlobal;
begin  -- Se activan T1 y T2.
  declare
    type PTTareaLocal is access TTarea;
    PunteroTareaGlobal2: PTTareaGlobal := new TTarea;
      -- Se activa PunteroTareaGlobal2.all después de la asignación new.
    PunteroTareaLocal: PTTareaLocal := new TTarea;
      -- Se activa PunteroTareaLocal.all después de la asignación new.
    T3: TTarea;
  begin  -- Se activa T3.
    -- ...
  end;  -- Se espera la terminación de T3 y PunteroTareaLocal.all.
-- Continúa la ejecución de PunteroTareaGlobal2.all.
-- ...
end;  -- Se espera la terminación de T1, T2, PunteroTareaGlobal1.all
      -- y PunteroTareaGlobal2.all.

generic
  ValorInicial: Natural := 1;  -- Parám. genérico con valor por defecto.
 package Semaforos is
  type TSemaforo is limited private;
  procedure Wait (Sem: in out TSemaforo);
  procedure Signal (Sem: in out TSemaforo);
private
  task type TSemaforo is
    entry Wait;
    entry Signal;
  end TSemaforo;
end Semaforos;

package body Semaforos is
  procedure Wait (Sem: in out TSemaforo) is
    begin
      Sem.Wait;  -- Llamada a punto de entrada de la tarea.
     end Wait;
  procedure Signal (Sem: in out TSemaforo) is
    begin
      Sem.Signal;  -- Llamada a punto de entrada de la tarea.
     end Signal;
  task body TSemaforo is
    S: Natural := ValorInicial;  -- Es el contador del semáforo.
   begin
    loop
      select
        when S > 0 =>
          accept Wait;
          S := S - 1;
      or
        accept Signal;
        S := S + 1;
      or
        terminate;
      end select;
    end loop;
  end TSemaforo;
end Semaforos;

with Semaforos;

procedure Prueba_Semaforos is
  package Paquete_Semaforos is new Semaforos;
  use Paquete_Semaforos;
  Semaforo: TSemaforo;
begin  -- Aquí se inicia la tarea de tipo TSemaforo (objeto Semaforo).
   -- ...
   Wait (Semaforo);
   -- ...
   Signal (Semaforo);
   -- ...
end Prueba_Semaforos;

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Numerics.Float_Random;

with Semaforos;

procedure Simulador_Trenes is

   Num_Estaciones : constant := 5;
   Num_Trenes : constant := 3;

   type Num_Estación is range 1 .. Num_Estaciones;
   type Num_Tren is range 1 .. Num_Trenes;

   package Num_Estación_IO is new Ada.Text_IO.Integer_IO (Num_Estación);
   use Num_Estación_IO;
   package Num_Tren_IO is new Ada.Text_IO.Integer_IO (Num_Tren);
   use Num_Tren_IO;

   package Semaforos_Inicial_1 is new
     Semaforos (Valorinicial => 1);
   use Semaforos_Inicial_1;

   Semaforos_Estaciones : array (Num_Estación) of TSemaforo;

   task type Tren is
      entry Comenzar (Tu_Num : in Num_Tren);
   end Tren;

   Lista_Trenes : array (Num_Tren) of Tren;

   task body Tren is

      Mi_Num: Num_Tren;

      procedure Pon_Nombre is
      begin
         Put ("Tren nº"); Put (Mi_Num); Put (": ");
      end Pon_Nombre;

      Espera_En_Estación: constant Duration := 5.0;
      Duración_Mínima: constant Duration := 2.0;
      Factor_Duración: constant Duration := 10.0;
      Azar_Gen: Ada.Numerics.Float_Random.Generator;

      Actual, Siguiente: Num_Estación;
   begin

      Ada.Numerics.Float_Random.Reset (Azar_Gen);

      accept Comenzar (Tu_Num : in Num_Tren) do
         Mi_Num := Tu_Num;
      end Comenzar;

      Pon_Nombre;
      Put_Line ("Comienzo el trayecto");
      Actual := 1;

      loop

         Pon_Nombre; Put ("En estación "); Put (Actual); New_Line;

         delay Espera_En_Estación;

         if Actual = Num_Estaciones then
            Siguiente := 1;
         else
            Siguiente := Actual + 1;
         end if;

         Wait (Semaforos_Estaciones (Siguiente));

         Pon_Nombre;
         Put ("Trayecto hacia estación ");
         Put (Siguiente);
         New_Line;

         Signal (Semaforos_Estaciones (Actual));
         delay Duration (Ada.Numerics.Float_Random.Random (Azar_Gen))
           * Factor_Duración + Duración_Mínima;

         Actual := Siguiente;

      end loop;
   end Tren;

begin

   for I in Lista_Trenes'Range loop
      Lista_Trenes (I).Comenzar (Tu_Num => I);
   end loop;

end Simulador_Trenes;

generic
   type TElemento is private;
   Tamaño: Positive := 32;
package Buffer_servidor is
   type TBuffer is limited private;
   procedure EscribirBuf (B: in out TBuffer; E: TElemento);
   procedure LeerBuf (B: in out TBuffer; E: out TElemento);
private
   task type TBuffer is
      entry Escribir (E: TElemento);
      entry Leer (E: out TElemento);
   end TBuffer;
end Buffer_servidor;

package body Buffer_servidor is
   task body TBuffer is
      subtype TCardinalBuffer is Natural range 0 .. Tamaño;
      subtype TRangoBuffer is TCardinalBuffer range 0 .. Tamaño - 1;
      Buf: array (TRangoBuffer) of TElemento;
      Cima, Base: TRangoBuffer := 0;
      NumElementos: TCardinalBuffer := 0;
   begin
      loop
         select
            when NumElementos < Tamaño =>
               accept Escribir (E: TElemento) do
                  Buf(Cima) := E;
               end Escribir;
               Cima := TRangoBuffer(Integer(Cima + 1) mod Tamaño);
               NumElementos := NumElementos + 1;
         or
            when NumElementos > 0 =>
               accept Leer (E: out TElemento) do
                  E := Buf(Base);
               end Leer;
               Base := TRangoBuffer(Integer(Base + 1) mod Tamaño);
               NumElementos := NumElementos - 1;
         or
            terminate;
         end select;
      end loop;
   end TBuffer;

   procedure EscribirBuf (B: in out TBuffer; E: TElemento) is
   begin
      B.Escribir (E);
   end EscribirBuf;

   procedure LeerBuf (B: in out TBuffer; E: out TElemento) is
   begin
      B.Leer (E);
   end LeerBuf;
end Buffer_servidor;

with Text_IO, Buffer_servidor;
use Text_IO;
procedure Buffer is
  Clave_Salida : constant String := "Salir";
  type TMensaje is
    record
      NumOrden: Positive;
      Contenido: String (1..20);
    end record;
  package Cola_mensajes is new Buffer_servidor (TElemento => TMensaje);
  use Cola_mensajes;
  Cola: TBuffer;
  task Emisor;
  task Receptor;
  task body Emisor is
    M: TMensaje := (NumOrden => 1, Contenido => (others => ' '));
    Último: Natural;
  begin
    loop
      Put ("[Emisor] Mensaje: ");
      Get_Line (M.Contenido, Último);
      M.Contenido (Último + 1 .. M.Contenido'Last) := (others => ' ');
      EscribirBuf (Cola, M);
      M.NumOrden := M.NumOrden + 1;
      exit when M.Contenido(Clave_Salida'range) = Clave_Salida;
    end loop;
  end Emisor;
  task body Receptor is
    package Ent_IO is new Text_IO.Integer_IO(Integer);
    use Ent_IO;
    M: TMensaje;
  begin
    loop
      LeerBuf (Cola, M);
      exit when M.Contenido(Clave_Salida'range) = Clave_Salida;
      Put ("[Receptor] Mensaje número ");
      Put (M.NumOrden);
      Put (": ");
      Put (M.Contenido);
      New_Line;
    end loop;
  end Receptor;

begin
  null;
end Buffer;

with Ada.Text_IO; use Ada.Text_IO;

with Ada.Numerics.Discrete_Random;

procedure Barberia is

   type Rango_Demora is range 1 .. 30;
   type Duracion_Afeitado is range 5 .. 10;
   type Nombre_Cliente is (Jose, Juan, Iñaki, Antonio, Camilo);

   package Demora_Al_Azar is new Ada.Numerics.Discrete_Random
     (Rango_Demora);
   package Afeitado_Al_Azar is new Ada.Numerics.Discrete_Random
     (Duracion_Afeitado);

   task Barbero is
      entry Afeitar (Cliente : in Nombre_Cliente);
   end Barbero;

   task type Cliente is
      entry Comenzar (Nombre : in Nombre_Cliente);
   end Cliente;

   Lista_Clientes : array (Nombre_Cliente) of Cliente;

   task body Barbero is
      Generador : Afeitado_Al_Azar.Generator;
      Espera_Máxima_Por_Cliente : constant Duration := 30.0;
   begin
      Afeitado_Al_Azar.Reset (Generador);
      Put_Line ("Barbero: Abro la barbería.");
      loop
         Put_Line ("Barbero: Miro si hay cliente.");
         select
            accept Afeitar (Cliente : in Nombre_Cliente) do
               Put_Line ("Barbero: Afeitando a " & Nombre_Cliente'Image
                         (Cliente));
               delay Duration (Afeitado_Al_Azar.Random (Generador));
               Put_Line ("Barbero: Termino con " & Nombre_Cliente'Image
                         (Cliente));
            end Afeitar;
         or
            delay Espera_Máxima_Por_Cliente;
            Put_Line ("Barbero: Parece que ya no viene nadie,"
                      & " cierro la barbería.");
            exit;
         end select;
      end loop;
   end Barbero;

   task body Cliente is
      Generador : Demora_Al_Azar.Generator;
      Mi_Nombre : Nombre_Cliente;
   begin
      accept Comenzar (Nombre : in Nombre_Cliente) do
         Mi_Nombre := Nombre;
      end Comenzar;

      Demora_Al_Azar.Reset (Gen       => Generador,
                            Initiator => Nombre_Cliente'Pos (Mi_Nombre));

      delay Duration (Demora_Al_Azar.Random (Generador));

      Put_Line (Nombre_Cliente'Image (Mi_Nombre) &
                ": Entro en la barbería.");
      Barbero.Afeitar (Cliente => Mi_Nombre);
      Put_Line (Nombre_Cliente'Image (Mi_Nombre) &
                ": Estoy afeitado, me marcho.");
   end Cliente;

begin
   for I in Lista_Clientes'Range loop
      Lista_Clientes (I).Comenzar (Nombre => I);
   end loop;
end Barberia;

    package Cubiertos is

       type Cubierto is limited private;

       procedure Coger(C: in out Cubierto);
       procedure Soltar(C: in out Cubierto);

    private

       type Status is (LIBRE, OCUPADO);

       protected type Cubierto(Estado_Cubierto: Status := LIBRE) is
          entry Coger;
          entry Soltar;
       private
          Estado: Status := Estado_Cubierto;
       end Cubierto;

    end Cubiertos;

    package body Cubiertos is

       procedure Coger (C: in out Cubierto) is
       begin
          C.Coger;
       end Coger;

       procedure Soltar (C: in out Cubierto) is
       begin
          C.Soltar;
       end Soltar;

       protected body Cubierto is

          entry Coger when Estado = LIBRE is
          begin
             Estado := OCUPADO;
          end Coger;

          entry Soltar when Estado = OCUPADO is
          begin
             Estado := LIBRE;
          end Soltar;

       end Cubierto;

    end Cubiertos;

    with Ada.Text_IO; use Ada.Text_IO;
    with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
    with Cubiertos; use Cubiertos;

    procedure Problema_Filosofos is

       type PCubierto is access Cubierto;

       task type TFilosofo(Id: Character; Cubierto1: PCubierto; Cubierto2: PCubierto);

       task body TFilosofo is

          procedure Comer is
          begin
             Coger(Cubierto1.all);
             Coger(Cubierto2.all);
             for i in 1..10 loop
                Put(Id & "c ");
                delay 1.0;
             end loop;
             Soltar(Cubierto2.all);
             Soltar(Cubierto1.all);
          end Comer;

          Procedure Pensar is
          begin
             for i in 1..10 loop
                Put(Id & "p ");
                delay 1.0;
             end loop;
          end Pensar;

       begin
          loop
             Comer;
             Pensar;
          end loop;
       end TFilosofo;

       Num_Cubiertos: Positive;

    begin

       Put("Introduce el numero de cubiertos: "); Get(Num_Cubiertos); New_line;

       declare
          type PTFilosofo is access TFilosofo;
          P: PTFilosofo;
          C: Character := 'A';
          Cuberteria: array (1..Num_Cubiertos) of PCubierto;
       begin
          for i in 1..Num_Cubiertos loop
             Cuberteria(i) := new Cubierto;
          end loop;

          for i in 1..Num_Cubiertos-1 loop
            P := new TFilosofo(C, Cuberteria(i), Cuberteria(i+1));
            C := Character'Succ(C);
          end loop;
          P := new TFilosofo(C, Cuberteria(1), Cuberteria(Num_Cubiertos));
       end;
    end Problema_Filosofos;

          P := new TFilosofo(C, Cuberteria(Num_Cubiertos), Cuberteria(1));

-- Chinos2: Otra implementación concurrente en Ada
-- Tomás Javier Robles Prado
-- tjavier@usuarios.retecal.es

-- Uso: ./chinos <numero_jugadores>

-- El juego consiste en jugar sucesivas partidas a los chinos. Si un
--  jugador acierta, no paga y queda excluido de las siguientes
--  rondas. El último que quede paga los vinos

--   Copyright (C) 2003 T. Javier Robles Prado
--
--   This program is free software; you can redistribute it and/or modify
--   it under the terms of the GNU General Public License as published by
--   the Free Software Foundation; either version 2 of the License, or
--   (at your option) any later version.
--
--   This program is distributed in the hope that it will be useful,
--   but WITHOUT ANY WARRANTY; without even the implied warranty of
--   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--   GNU General Public License for more details.
--
--   You should have received a copy of the GNU General Public License
--   along with this program; if not, write to the Free Software
--   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

with Ada.Text_IO; use Ada.Text_IO;

with Ada.Numerics.Discrete_Random;
with Ada.Command_Line;
with Ada.Strings.Unbounded;
with Ada.Exceptions;

procedure Chinos is

   -- Número Máximo Jugadores que pueden participar (aforo máximo del bar)
   MAX   : constant Natural := 20;

   -- Posibles mensajes que recibe un jugador tras una partida
   type Estados is (NO_SIGUES_JUGANDO, SIGUES_JUGANDO, HAS_PERDIDO);

   -- Subtipo que modela el número de jugadores posibles

   subtype NumMaxJugadores is Natural range 0..MAX;

   -- Modela la máxima apuesta que puede darse
   subtype MAX_APUESTA is Natural range 0..3*MAX;

   -- Nombres posibles para los jugadores. El 0 se utilizará para

   --  controlar el caso de que no haya ganador en una partida
   subtype TNombre is Integer range -1..MAX;

   -- Paquete para Numeros aleatorios:
   package Integer_Random is new Ada.Numerics.Discrete_Random(MAX_APUESTA);

   -- Apuesta de cada Jugador

   Subtype TApuesta is  Integer range -1..3*MAX;

   -- Mano de cada jugador
   subtype TMano is Natural range 0..3;

   -- Ficha de cada jugador que guardara el arbitro

   type TFicha is record
      Nombre       : TNombre;
      Apuesta      : TApuesta := -1;
      Mano         : TMano;
      SigueJugando : Boolean;
   end record;

   -- Array de Fichas
   type TTablon is array(1..MAX) of TFicha;

   -- Se define el tipo jugador

   task type Jugador;

   task  Arbitro is
      -- El árbitro controla las partidas y sincroniza a los jugadores

      entry FijaNumeroJugadores (Num : in NumMaxJugadores);
      -- Recoge el argumento de la línea de comandos para saber

      --  cuántos jugadores van a participar

      entry AsignaNombre (Nombre: out TNombre; NumJug: out NumMaxJugadores);
      -- Asigna Nombres (de 1 a NumerosJugadores) a los jugadores que

      --  van a participar. A los que no, les asigna un -1 como
      --  indicación de que finalicen.

      entry SiguesJugando
        (Nombre: in TNombre;
         JugadorSigueJugando : out Estados;
         HuboGanador : out boolean);
      -- Mensaje que envía el árbitro a cada jugador tras una

      --  partida, comunicándole si ha ganado y deja de jugar, si
      --  sigue jugando o si ha perdido y tiene que pagar

      entry EnviaApuesta (Nombre: in TNombre ; Apuesta: in TApuesta);
      -- El árbitro recibe la apuesta de un jugador

      entry ConfirmaApuesta (Confirmada : out Boolean);
      -- Respuesta del árbitro sobre si la apuesta es válida (no la
      --  ha hecho otro antes)

      entry ReEnviaApuesta (Apuesta: in TApuesta);
      -- Si la apuesta no es válida se reenvia hasta que lo sea

      entry EnviaMano (Nombre: in TNombre ; Mano: in TMano);
      -- El jugador envía el número de manos que saca al árbitro

   end Arbitro;

   task body Arbitro is

      -- Funciones y Procedimientos

      function NumeroJugadores return NumMaxJugadores is

         -- Devuelve el número de jugadores
      begin
         return 5;
      end NumeroJugadores;

      function EsApuestaValida (Apuesta: in TApuesta; Tablon: in TTablon)
                               return Boolean is

         -- Devuelve verdadero si la apuesta no ha sido realizada
         --  antes por algún otro jugador

         Valida : Boolean := True ;
         I      : TNombre := 1;
      begin

         for I in 1..MAX loop

            if Tablon(I).SigueJugando then
               if Tablon(I).Apuesta = Apuesta  then
                  -- Ya está dicha, la apuesta NO es válida

                  Valida := False ;
               end if;
            end if;
         end loop;

         return Valida;
      end EsApuestaValida;

      function ResultadoGanador (Tablon: in TTablon) return TApuesta is

         -- Devuelve el número de monedas que sacaron los jugadores
         Suma : TApuesta := 0 ;
      begin
         for I in 1..MAX loop

            if Tablon(I).SigueJugando then
               Suma := Suma + Tablon(I).Mano ;
            end if;
         end loop;
         return Suma;
      end ResultadoGanador;

      procedure ImprimeGanador (Tablon: in TTablon) is

         -- Imprimer el nombre del ganador
         I         : TNombre := 1 ;
         Resultado : TApuesta ;
         Terminar  : Boolean := False;
      begin
         Resultado := ResultadoGanador(Tablon);
         while not Terminar loop

            if Tablon(I).Apuesta = Resultado and Tablon(I).SigueJugando then

               Put_Line("Ha Ganado el Jugador " & I'Img);
               Terminar := True ;
            else
               if I = MAX then
                  Put_Line("No ha habido Ganador");
                  Terminar := True;
               else

                  I :=  I + 1;
               end if;
            end if;

         end loop;
      end ImprimeGanador;

      function JugadorEliminado (Tablon: in TTablon) return NumMaxJugadores is

         -- Devuelve el jugador que cuya apuesta sea la correcta

         Resultado : TApuesta;

         Ganador   : NumMaxJugadores := 0;
      begin
         Resultado := ResultadoGanador(Tablon);

         for I in 1..MAX loop

            if Tablon(I).SigueJugando then

               if Resultado =  Tablon(I).Apuesta then
                  Ganador := I ;
               end if;
            end if;
         end loop;

         return Ganador;
      end JugadorEliminado;

      procedure ImprimeTablon(Tablon: in TTablon) is

         -- Imprime las apuestas y monedas de los jugadores
      begin

         for I in 1..MAX loop
            if Tablon(I).SigueJugando then

               Put_Line("Nombre =" & Tablon(I).Nombre'Img &
                                " | Apuesta =" & Tablon(I).Apuesta'Img &
                                " | Mano =" &Tablon(I).Mano'Img );
            end if;
         end loop;
         Put_Line
           ("Resultado ganador: " & ResultadoGanador(Tablon)'Img);

      end ImprimeTablon;

      procedure SeparaPartidas (NumPar :in Natural)  is

         -- Un simple separador para aumentar la claridad
      begin
         New_Line;
         Put_Line("******************************************");
         Put_Line("Partida número " & NumPar'Img);
         Put_Line("******************************************");
      end SeparaPartidas;

      -- Variables

      -- Número de jugadores de la partida
      N : NumMaxJugadores;
      Permitidos : NumMaxJugadores;

      -- Partida Actual
      PartidaActual : NumMaxJugadores;

      -- Tablón
      Tablon : TTablon;

      NombreActual : NumMaxJugadores;
      ApuestaValida : Boolean;
      Ganador : NumMaxJugadores;

      NumeroPartida :  Natural;

   begin

      -- Averigua número de jugadores

      accept FijaNumeroJugadores (Num : in NumMaxJugadores) do
         N := Num;
      end FijaNumeroJugadores;

      -- Nombra solo a aquellos que vayan a jugar, a los que no, los

      --  nombra como -1
      Permitidos := N;

      for I in 1..MAX loop
         accept AsignaNombre

           (Nombre: out TNombre ; NumJug: out NumMaxJugadores) do
            if Permitidos > 0 then

               Nombre := I;
               NumJug := N;
               Tablon(I).Nombre  := I ;
               Tablon(I).SigueJugando  := True;
               Permitidos := Permitidos - 1;
            else
               Nombre := -1;
               Tablon(I).Nombre := -1;
               Tablon(I).SigueJugando := False;

            end if;
         end AsignaNombre;
      end loop;

      NumeroPartida := 1;

      while N /= 1 loop

         -- Para separar las diferentes partidas
         SeparaPartidas(NumeroPartida);

         -- Recibe las apuestas de cada jugador
         for I in 1..N loop
            accept EnviaApuesta (Nombre: in TNombre; Apuesta: in TApuesta) do

               NombreActual := Nombre;
               ApuestaValida := EsApuestaValida(Apuesta,Tablon);
               if ApuestaValida then
                  Tablon(Nombre).Apuesta := Apuesta ;
               end if;
            end EnviaApuesta;

            -- La Apuesta es Válida, se confirma y a otra cosa

            if ApuestaValida then
               accept ConfirmaApuesta(Confirmada: out Boolean) do

                  Confirmada := True;
               end ConfirmaApuesta;

            else
               -- La apuesta no es válida. Se comunica esto al jugador para
               -- que envíe una nueva apuesta
               accept ConfirmaApuesta(Confirmada: out Boolean) do

                  Confirmada := False;
               end ConfirmaApuesta;
               while not ApuestaValida loop
                  -- Aceptará diferentes apuestas hasta q sea válida.

                  accept ReEnviaApuesta (Apuesta: in TApuesta) do
                     if EsApuestaValida(Apuesta,Tablon) then

                        ApuestaValida := True;
                        Tablon(NombreActual).Apuesta := Apuesta ;
                     end if;
                  end ReEnviaApuesta;
                  accept ConfirmaApuesta(Confirmada: out Boolean) do

                     Confirmada := ApuestaValida;
                  end ConfirmaApuesta;
               end loop;

            end if;
         end loop;

         -- Recibe lo q saca cada jugador

         for I in 1..N loop
            accept EnviaMano(Nombre: in TNombre; Mano: in TMano) do

               Tablon(Nombre).Mano := Mano ;
            end EnviaMano;
         end loop;

         -- ImprimeResultados de la partida
         ImprimeTablon(Tablon);
         ImprimeGanador(Tablon);

         -- Envía a cada jugador su nuevo estado
         Ganador  := JugadorEliminado (Tablon);
         if Ganador = 0 then

            -- Nadie acertó
            for I in 1..N loop
               accept SiguesJugando

                 (Nombre: in TNombre;
                  JugadorSigueJugando : out Estados;
                  HuboGanador : out boolean) do

                  JugadorSigueJugando := SIGUES_JUGANDO;
                  Tablon(Nombre).SigueJugando := True;
                  HuboGanador := false ;
               end SiguesJugando;
            end loop;

         else
            -- Hay ganador
            for I in 1..N loop

               accept SiguesJugando
                 (Nombre: in TNombre;
                  JugadorSigueJugando : out Estados;
                  HuboGanador : out boolean) do

                  HuboGanador := true;
                  if Nombre = Ganador then
                     JugadorSigueJugando := NO_SIGUES_JUGANDO;
                     Tablon(Nombre).SigueJugando := False;
                  else
                     if N /= 2 then

                        JugadorSigueJugando := SIGUES_JUGANDO;
                        Tablon(Nombre).SigueJugando := True;
                     else
                        JugadorSigueJugando := HAS_PERDIDO;
                        Tablon(Nombre).SigueJugando := False;
                     end if;
                  end if;
               end SiguesJugando;
            end loop;
         end if;

         NumeroPartida := NumeroPartida + 1;
         if Ganador /= 0 then

            N := N - 1;
         end if;

      end loop;

   end Arbitro;

   task body Jugador is

      MiNombre : TNombre;
      NumJug   : NumMaxJugadores;
      Apuesta : TApuesta;
      ApuestaValidada : Boolean;
      Mano    : Tmano;
      G : Integer_Random.Generator;
      YoSigo : Estados;
      Terminar : Boolean := False;
      HuboGanador : boolean;

   begin
      Arbitro.AsignaNombre(MiNombre, NumJug);

      -- Si MiNombre es -1, entonces termina su ejecución. Se sigue
      --  este método para ceñirnos a los jugadores que quiere el
      --  usuario
      if MiNombre /= -1 then

         -- Semillas aleatorias
         Integer_Random.Reset(G);

         while not Terminar loop

            -- Envia Apuesta
            for I in 1..MiNombre loop

               Apuesta := Integer_Random.Random(G) mod (NumJug * 3);
            end loop;
            Arbitro.EnviaApuesta(MiNombre, Apuesta);

            -- Proceso de confirmación de apuesta
            ApuestaValidada := False ;
            while not ApuestaValidada loop

               Arbitro.ConfirmaApuesta(ApuestaValidada);
               if not ApuestaValidada then
                  -- Genera Nueva apuesta
                  for I in 1..MiNombre loop

                     Apuesta := Integer_Random.Random(G) mod (NumJug * 3) ;
                  end loop;
                  Arbitro.ReEnviaApuesta(Apuesta);
               end if;

            end loop;

            -- Envía Mano

            for I in 1..MiNombre loop
               Mano := Integer_Random.Random(G) mod 4;
            end loop;
            Arbitro.EnviaMano(MiNombre, Mano);

            -- Comprueba su estado, si sigue jugando, si ha perdido o

            --  si ha ganado y deja de jugar
            Arbitro.SiguesJugando(MiNombre, YoSigo, HuboGanador);
            if YoSigo = SIGUES_JUGANDO then
               Terminar := False;
            else
               if YoSigo = NO_SIGUES_JUGANDO then

                  Terminar := True;
               else
                  -- Ha perdido
                  Put_Line("Jugador " & MiNombre'Img &
                                   ": He perdido, tengo que pagar :_(");
               end if;

            end if;
            if HuboGanador then

               NumJug := NumJug - 1;
            end if;
         end loop;

      end if;

   end Jugador;

   Jugadores : array (1..MAX) of Jugador;
   NumJug : Natural;

begin
   if Ada.Command_Line.Argument_Count /= 1 then
      -- Número incorrecto de parámetros
      Put_Line("Uso: ./chinos <num_jugadores>");
      NumJug := 1;

   else

      NumJug := Integer'Value(Ada.Command_Line.Argument(1));

      if NumJug < 2 then
         -- Número mínimo de jugadores
         Put_Line("El número de jugadores ha de ser mayor que 1." &

                          NumJug'Img & " no es mayor que 1");
         Put_Line("Seleccione un valor mayor o igual que 2");
         NumJug := 1;
      end if;

      if NumJug > MAX then

         -- Número máximo de jugadores
         Put_Line(NumJug'Img & " es mayor que " & MAX'Img);
         Put_Line("Seleccione un valor menor o igual que " &
                              MAX'Img);
         NumJug := 1;
      end if;

   end if;

   Arbitro.FijaNumeroJugadores(NumJug);

   -- Por si nos intentan colar algún valor no válido

exception
   when Constraint_Error =>
      NumJug := 1;
      Arbitro.FijaNumeroJugadores(NumJug);
      Put_Line("El Valor Introducido no es correcto.");
      Put_Line("Uso: ./chinos <num_jugadores>");

end Chinos;

gnatdist
gnatdist
gnatdist
gnatdist
gnatdist
gnatdist
gnatdist Ejemplo_Configuracion1.cfg

configuration
configuration Ejemplo_Configuracion1 is
     --
     -- Código de la configuración
     --
end Ejemplo_Configuracion1;

package Calculadora is

  pragma Remote_Call_Interface;

  function Sumar  (Operando1, Operando2 : Integer) return Integer; 
  function Restar (Operando1, Operando2 : Integer) return Integer;

end Calculadora;

package body Calculadora is

    function Sumar (Operando1, Operando2 : Integer) return Integer is
    begin
       return Operando1 + Operando2;
    end Sumar;

    function Restar (Operando1, Operando2 : Integer) return Integer is
    begin
       return Operando1 - Operando2;
    end Restar;

end Calculadora;     

with Ada.Text_IO;   use Ada.Text_IO;
with Calculadora;

procedure Cliente is
begin

   Put_Line ("Calculadora, ¿cuanto es 321+123? " &
             Integer'Image (Calculadora.Sumar (321,123)));

   Put_Line ("Calculadora, ¿cuanto es 321-123? " &
             Integer'Image (Calculadora.Restar (321,123)));

end Cliente;     

gnatdist
       configuration ejemplo is
         pragma Starter (Ada);

         Particion1 : Partition := (Calculadora);
         Particion2 : Partition := (Cliente);

         procedure Cliente is in Particion2;
       end ejemplo;     

gnatdist
gnatdist
gnatdist
gnatdist
gnatdist ejemplo.cfg

       gnatdist: checking configuration consistency
        ------------------------------
        ---- Configuration report ----
        ------------------------------
       Configuration :
          Name        : ejemplo
          Main        : cliente
          Starter     : Ada code

       Partition particion1
          Units       :
                    - calculadora (rci)

       Partition particion2
          Main        : cliente
          Units       :
          Name        : ejemplo
          Main        : cliente
          Starter     : Ada code

       Partition particion1
          Units       :
                    - calculadora (rci)

       Partition particion2
          Main        : cliente
          Units       :
                    - cliente (normal)

        -------------------------------
       gnatdist: building calculadora caller stubs from calculadora.ads
       gnatdist: building calculadora receiver stubs from calculadora.adb
       gnatdist: building partition particion1
       gnatdist: building partition particion2
       gnatdist: generating starter cliente      

lrwxrwxrwx    1 alo      alo            10 Oct  9 22:33 cliente -> particion2
-rwxr-xr-x    1 alo      alo       3663802 Oct  9 22:33 particion1
-rwxr-xr-x    1 alo      alo       3723193 Oct  9 22:33 particion2

gnatdist
       $ ./cliente
       Host for "particion1": localhost
       - Calculadora, ¿cuanto es 321+123? =  444
       - Calculadora, ¿cuanto es 321-123? =  198     

       [..]

7701 pts/10   S      0:00  \_ bash
8753 pts/10   S      0:00  |   \_ ./cliente
8754 pts/10   S      0:00  |       \_ ./cliente
8755 pts/10   S      0:00  |           \_ ./cliente
8793 pts/10   S      0:00  |           \_ ./cliente

        [..]

8788 ?        S      0:00 /home/alo/prog/glade/1/particion1 --detach --boot_location tcp://localhost:35802
8790 ?        R      0:00  \_ /home/alo/prog/glade/1/particion1 --detach --boot_location tcp://localhost:35802
8791 ?        S      0:00      \_ /home/alo/prog/glade/1/particion1 --detach --boot_location tcp://localhost:35802
8792 ?        S      0:00      \_ /home/alo/prog/glade/1/particion1 --detach --boot_location tcp://localhost:35802
8794 ?        R      0:00      \_ /home/alo/prog/glade/1/particion1 --detach --boot_location tcp://localhost:35802

08050500 g     F .text    00000011              calculadora__restar
080504f0 g     F .text    0000000d              calculadora__sumar     

gnatdist
080502c0 l     F .text    00000018              calculadora__sumar___clean.0
080502e0 l     F .text    0000005a              calculadora__sumar___input27___read30.2
08050340 l     F .text    0000018a              calculadora__sumar___input27.1
080504d0 g     F .text    000002bf              calculadora__sumar
08050790 l     F .text    00000018              calculadora__restar___clean.3
080507b0 l     F .text    0000005a              calculadora__restar___input67___read70.5
08050810 l     F .text    0000018a              calculadora__restar___input67.4
080509a0 g     F .text    000002bf              calculadora__restar

# apt-get install gnat gnat-glade

# apt-get install gnat-glade-doc gnat-doc

Integer
Boolean
with Standard; use Standard;

ASCII
CR
LF
use ASCII;
CR
ASCII
Ada.Characters.Latin_1
 package Standard is
   pragma Pure(Standard);

   type Boolean is (False, True);

   -- The predefined relational operators for this type are as follows:

   -- function "="   (Left, Right : Boolean'Base) return Boolean;
   -- function "/="  (Left, Right : Boolean'Base) return Boolean;
   -- function "<"   (Left, Right : Boolean'Base) return Boolean;
   -- function "<="  (Left, Right : Boolean'Base) return Boolean;
   -- function ">"   (Left, Right : Boolean'Base) return Boolean;
   -- function ">="  (Left, Right : Boolean'Base) return Boolean;

   -- The predefined logical operators and the predefined logical
   -- negation operator are as follows:

   -- function "and" (Left, Right : Boolean'Base) return Boolean;
   -- function "or"  (Left, Right : Boolean'Base) return Boolean;
   -- function "xor" (Left, Right : Boolean'Base) return Boolean;

   -- function "not" (Right : Boolean'Base) return Boolean;

   -- The integer type root_integer is predefined.
   -- The corresponding universal type is universal_integer.

   type Integer is range ''implementation-defined'';

   subtype Natural  is Integer range 0 .. Integer'Last;
   subtype Positive is Integer range 1 .. Integer'Last;

   -- The predefined operators for type Integer are as follows:

   -- function "="  (Left, Right : Integer'Base) return Boolean;
   -- function "/=" (Left, Right : Integer'Base) return Boolean;
   -- function "<"  (Left, Right : Integer'Base) return Boolean;
   -- function "<=" (Left, Right : Integer'Base) return Boolean;
   -- function ">"  (Left, Right : Integer'Base) return Boolean;
   -- function ">=" (Left, Right : Integer'Base) return Boolean;

   -- function "+"   (Right : Integer'Base) return Integer'Base;
   -- function "-"   (Right : Integer'Base) return Integer'Base;
   -- function "abs" (Right : Integer'Base) return Integer'Base;

   -- function "+"   (Left, Right : Integer'Base) return Integer'Base;
   -- function "-"   (Left, Right : Integer'Base) return Integer'Base;
   -- function "*"   (Left, Right : Integer'Base) return Integer'Base;
   -- function "/"   (Left, Right : Integer'Base) return Integer'Base;
   -- function "rem" (Left, Right : Integer'Base) return Integer'Base;
   -- function "mod" (Left, Right : Integer'Base) return Integer'Base;

   -- function "**"  (Left : Integer'Base; Right : Natural)
   --                  return Integer'Base;

   -- The specification of each operator for the type
   -- root_integer, or for any additional predefined integer
   -- type, is obtained by replacing Integer by the name of the type
   -- in the specification of the corresponding operator of the type
   -- Integer. The right operand of the exponentiation operator
   -- remains as subtype Natural.

   -- The floating point type root_real is predefined.
   -- The corresponding universal type is universal_real.

   type Float is digits ''implementation-defined'';

   -- The predefined operators for this type are as follows:

   -- function "="   (Left, Right : Float) return Boolean;
   -- function "/="  (Left, Right : Float) return Boolean;
   -- function "<"   (Left, Right : Float) return Boolean;
   -- function "<="  (Left, Right : Float) return Boolean;
   -- function ">"   (Left, Right : Float) return Boolean;
   -- function ">="  (Left, Right : Float) return Boolean;

   -- function "+"   (Right : Float) return Float;
   -- function "-"   (Right : Float) return Float;
   -- function "abs" (Right : Float) return Float;

   -- function "+"   (Left, Right : Float) return Float;
   -- function "-"   (Left, Right : Float) return Float;
   -- function "*"   (Left, Right : Float) return Float;
   -- function "/"   (Left, Right : Float) return Float;

   -- function "**"  (Left : Float; Right : Integer'Base) return Float;

   -- The specification of each operator for the type root_real, or for
   -- any additional predefined floating point type, is obtained by
   -- replacing Float by the name of the type in the specification of the
   -- corresponding operator of the type Float.

   -- In addition, the following operators are predefined for the root
   -- numeric types:

   function "*" (Left : root_integer; Right : root_real)
     return root_real;

   function "*" (Left : root_real;    Right : root_integer)
     return root_real;

   function "/" (Left : root_real;    Right : root_integer)
     return root_real;

   -- The type universal_fixed is predefined.
   -- The only multiplying operators defined between
   -- fixed point types are

   function "*" (Left : universal_fixed; Right : universal_fixed)
     return universal_fixed;

   function "/" (Left : universal_fixed; Right : universal_fixed)
     return universal_fixed;

      -- The declaration of type Character is based on the standard ISO 8859-1 character set.

      -- There are no character literals corresponding to the positions for control characters.
      -- They are indicated in italics in this definition. See 3.5.2.

   type Character is
     (nul,     soh,   stx,    etx,      eot,   enq,    ack,   bel,   --0 (16#00#) .. 7 (16#07#)
      bs,      ht,    lf,     vt,       ff,    cr,     so,    si,    --8 (16#08#) .. 15 (16#0F#)

      dle,     dc1,   dc2,    dc3,      dc4,   nak,    syn,   etb,   --16 (16#10#) .. 23 (16#17#)
      can,     em,    sub,    esc,      fs,    gs,     rs,    us,    --24 (16#18#) .. 31 (16#1F#)

      ' ',     '!',   '"',    '#',      '$',   '%',    '&',   ''',   --32 (16#20#) .. 39 (16#27#) "
      '(',     ')',   '*',    '+',      ',',   '-',    '.',   '/',   --40 (16#28#) .. 47 (16#2F#)

      '0',     '1',   '2',    '3',      '4',   '5',    '6',   '7',   --48 (16#30#) .. 55 (16#37#)
      '8',     '9',   ':',    ';',      '<',   '=',    '>',   '?',   --56 (16#38#) .. 63 (16#3F#)

      '@',     'A',   'B',    'C',      'D',   'E',    'F',   'G',   --64 (16#40#) .. 71 (16#47#)
      'H',     'I',   'J',    'K',      'L',   'M',    'N',   'O',   --72 (16#48#) .. 79 (16#4F#)

      'P',     'Q',   'R',    'S',      'T',   'U',    'V',   'W',   --80 (16#50#) .. 87 (16#57#)
      'X',     'Y',   'Z',    '[',      '\',   ']',    '^',   '_',   --88 (16#58#) .. 95 (16#5F#)

      '`',     'a',   'b',    'c',      'd',   'e',    'f',   'g',   --96 (16#60#) .. 103 (16#67#)
      'h',     'i',   'j',    'k',      'l',   'm',    'n',   'o',   --104 (16#68#) .. 111 (16#6F#)

      'p',     'q',   'r',    's',      't',   'u',    'v',   'w',   --112 (16#70#) .. 119 (16#77#)
      'x',     'y',   'z',    '{',      '|',   '}',    '~',   del,   --120 (16#78#) .. 127 (16#7F#)

      reserved_128,   reserved_129,     bph,   nbh,                  --128 (16#80#) .. 131 (16#83#)
      reserved_132,   nel,    ssa,      esa,                         --132 (16#84#) .. 135 (16#87#)
      hts,     htj,   vts,    pld,      plu,   ri,     ss2,   ss3,   --136 (16#88#) .. 143 (16#8F#)

      dcs,     pu1,   pu2,    sts,      cch,   mw,     spa,   epa,   --144 (16#90#) .. 151 (16#97#)
      sos,     reserved_153,  sci,      csi,                         --152 (16#98#) .. 155 (16#9B#)
      st,      osc,   pm,     apc,                                   --156 (16#9C#) .. 159 (16#9F#)

      ' ',     '¡',   '¢',    '£',      '¤',   '¥',    '¦',   '§',   --160 (16#A0#) .. 167 (16#A7#)
      '¨',     '©',   'ª',    '«',      '¬',   '',    '®',   '¯',   --168 (16#A8#) .. 175 (16#AF#)

      '°',     '±',   '²',    '³',      '´',   'µ',    '¶',   '·',   --176 (16#B0#) .. 183 (16#B7#)
      '¸',     '¹',   'º',    '»',      '¼',   '½',    '¾',   '¿',   --184 (16#B8#) .. 191 (16#BF#)

      'À',     'Á',   'Â',    'Ã',      'Ä',   'Å',    'Æ',   'Ç',   --192 (16#C0#) .. 199 (16#C7#)
      'È',     'É',   'Ê',    'Ë',      'Ì',   'Í',    'Î',   'Ï',   --200 (16#C8#) .. 207 (16#CF#)

      'Ð',     'Ñ',   'Ò',    'Ó',      'Ô',   'Õ',    'Ö',   '×',   --208 (16#D0#) .. 215 (16#D7#)
      'Ø',     'Ù',   'Ú',    'Û',      'Ü',   'Ý',    'Þ',   'ß',   --216 (16#D8#) .. 223 (16#DF#)

      'à',     'á',   'â',    'ã',      'ä',   'å',    'æ',   'ç',   --224 (16#E0#) .. 231 (16#E7#)
      'è',     'é',   'ê',    'ë',      'ì',   'í',    'î',   'ï',   --232 (16#E8#) .. 239 (16#EF#)

      'ð',     'ñ',   'ò',    'ó',      'ô',   'õ',    'ö',   '÷',   --240 (16#F0#) .. 247 (16#F7#)
      'ø',     'ù',   'ú',    'û',      'ü',   'ý',    'þ',   'ÿ',   --248 (16#F8#) .. 255 (16#FF#)

   -- The predefined operators for the type Character are the same as for
   -- any enumeration type.

   -- The declaration of type Wide_Character is based on the standard ISO 10646 BMP character set.
   -- The first 256 positions have the same contents as type Character. See 3.5.2.

   type Wide_Character is (nul, soh ... FFFE, FFFF);

   package ASCII is ... end ASCII;  --Obsolescent; see J.5

   -- Predefined string types:

   type String is array(Positive range <>) of Character;
   pragma Pack(String);

   -- The predefined operators for this type are as follows:

   --     function "="  (Left, Right: String) return Boolean;
   --     function "/=" (Left, Right: String) return Boolean;
   --     function "<"  (Left, Right: String) return Boolean;
   --     function "<=" (Left, Right: String) return Boolean;
   --     function ">"  (Left, Right: String) return Boolean;
   --     function ">=" (Left, Right: String) return Boolean;

   --     function "&" (Left: String;    Right: String)    return String;
   --     function "&" (Left: Character; Right: String)    return String;
   --     function "&" (Left: String;    Right: Character) return String;
   --     function "&" (Left: Character; Right: Character) return String;

   type Wide_String is array(Positive range <>) of Wide_Character;
   pragma Pack(Wide_String);

   -- The predefined operators for this type correspond to those for String

   type Duration is delta ''implementation-defined'' range ''implementation-defined'';

      -- The predefined operators for the type Duration are the same as for
      -- any fixed point type.

   -- The predefined exceptions:

   Constraint_Error: exception;
   Program_Error   : exception;
   Storage_Error   : exception;
   Tasking_Error   : exception;

 end Standard;

with Ada.Exceptions; use Ada.Exceptions;
-- ...
exception
  when Evento: PresiónElevada | TemperaturaElevada =>
    Put ("Excepción: ");
    Put (Exception_Name(Evento));
    New_Line;
  when Evento: others =>
    Put ("Excepción no prevista: ");
    Put (Exception_Name(Evento));
    New_Line;
    Put (Exception_Message(Evento));
end;

declare
  Fallo_Válvula: exception;
  Id: Ada.Exceptions.Exception_Id;
begin
  -- ...
  Id := Fallo_Válvula'Identity;
  -- ...
end;

declare
  Fallo_Válvula : exception;
begin
  -- ...
  Raise_Exception (Fallo_Válvula'Identity, "Error de apertura");
  -- ...
  Raise_Exception (Fallo_Válvula'Identity, "Error de cierre");
  -- ...
exception
  when Evento: Fallo_Válvula =>
    Put(Exception_Message(Evento));
end;

raise Fallo_Válvula with "Error de apertura";

package Ada.Exceptions is
   type Exception_Id is private;
   Null_Id : constant Exception_Id;
   function Exception_Name(Id : Exception_Id) return String;

   type Exception_Occurrence is limited private;
   type Exception_Occurrence_Access is access all Exception_Occurrence;
   Null_Occurrence : constant Exception_Occurrence;

   procedure Raise_Exception(E : in Exception_Id;
                             Message : in String := "");
   function Exception_Message(X : Exception_Occurrence) return String;
   procedure Reraise_Occurrence(X : in Exception_Occurrence);

   function Exception_Identity(X : Exception_Occurrence)
                               return Exception_Id;
   function Exception_Name(X : Exception_Occurrence) return String;
       -- Same as Exception_Name(Exception_Identity(X)).
   function Exception_Information(X : Exception_Occurrence) return String;

   procedure Save_Occurrence(Target : out Exception_Occurrence;
                             Source : in Exception_Occurrence);
   function Save_Occurrence(Source : Exception_Occurrence)
                            return Exception_Occurrence_Access;
private
  ... -- not specified by the language
end Ada.Exceptions;

package Fechas is

   type Fecha is
      record
         Dia : Positive range 1 .. 31;
         Mes : Positive range 1 .. 12;
         Año : Positive range 1 .. 3000;
      end record;

   subtype String_Fecha is String (1..10);

   -- Pasa la fecha a string en formato "dd-mm-aaaa".
   -- 
   function Imagen (F: Fecha) return String_Fecha;

end Fechas;

with Ada.Strings.Fixed;

use Ada.Strings.Fixed;
use Ada.Strings;

package body Fechas is

   function Imagen (F: Fecha) return String_fecha is

      procedure Mover_Imagen_Positive (N: Positive; S: in out String) is
      begin

         -- Move copia un string en otro de otro tamaño, añadiendo un
         -- padding opcionalmente. Trim elimina los blancos a izquierda o
         -- derecha (en este caso el blanco que pone el 'Image).
         Move
           (Source  => Trim (Positive'Image (N), Left),
            Target  => S,
            Justify => Right,
            Pad     => '0');
      end Mover_Imagen_Positive;

      S_Fecha : String_Fecha;
   begin

      Mover_Imagen_Positive (F.Dia, S_Fecha (1..2));
      S_Fecha (3) := '-';
      Mover_Imagen_Positive (F.Mes, S_Fecha (4..5));
      S_Fecha (6) := '-';
      Mover_Imagen_Positive (F.Año, S_Fecha (7..10));

      return S_Fecha;

   end Imagen;

end Fechas;

with Ada.Strings.Maps;
package Ada.Strings.Fixed is
   pragma Preelaborate(Fixed);

-- "Copy" procedure for strings of possibly different lengths

   procedure Move (Source  : in  String;
                   Target  : out String;
                   Drop    : in  Truncation := Error;
                   Justify : in  Alignment  := Left;
                   Pad     : in  Character  := Space);

-- Search subprograms

   function Index (Source   : in String;
                   Pattern  : in String;
                   Going    : in Direction := Forward;
                   Mapping  : in Maps.Character_Mapping
                                := Maps.Identity)
      return Natural;

   function Index (Source   : in String;
                   Pattern  : in String;
                   Going    : in Direction := Forward;
                   Mapping  : in Maps.Character_Mapping_Function)
      return Natural;

   function Index (Source : in String;
                   Set    : in Maps.Character_Set;
                   Test   : in Membership := Inside;
                   Going  : in Direction  := Forward)
      return Natural;

   function Index_Non_Blank (Source : in String;
                             Going  : in Direction := Forward)
      return Natural;

   function Count (Source   : in String;
                   Pattern  : in String;
                   Mapping  : in Maps.Character_Mapping
                                 := Maps.Identity)
      return Natural;

   function Count (Source   : in String;
                   Pattern  : in String;
                   Mapping  : in Maps.Character_Mapping_Function)
      return Natural;

   function Count (Source   : in String;
                   Set      : in Maps.Character_Set)
      return Natural;

   procedure Find_Token (Source : in String;
                         Set    : in Maps.Character_Set;
                         Test   : in Membership;
                         First  : out Positive;
                         Last   : out Natural);

-- String translation subprograms

   function Translate (Source  : in String;
                       Mapping : in Maps.Character_Mapping)
      return String;

   procedure Translate (Source  : in out String;
                        Mapping : in Maps.Character_Mapping);

   function Translate (Source  : in String;
                       Mapping : in Maps.Character_Mapping_Function)
      return String;

   procedure Translate (Source  : in out String;
                        Mapping : in Maps.Character_Mapping_Function);

-- String transformation subprograms

   function Replace_Slice (Source   : in String;
                           Low      : in Positive;
                           High     : in Natural;
                           By       : in String)
      return String;

   procedure Replace_Slice (Source   : in out String;
                            Low      : in Positive;
                            High     : in Natural;
                            By       : in String;
                            Drop     : in Truncation := Error;
                            Justify  : in Alignment  := Left;
                            Pad      : in Character  := Space);

   function Insert (Source   : in String;
                    Before   : in Positive;
                    New_Item : in String)
      return String;

   procedure Insert (Source   : in out String;
                     Before   : in Positive;
                     New_Item : in String;
                     Drop     : in Truncation := Error);

   function Overwrite (Source   : in String;
                       Position : in Positive;
                       New_Item : in String)
      return String;

   procedure Overwrite (Source   : in out String;
                        Position : in Positive;
                        New_Item : in String;
                        Drop     : in Truncation := Right);

   function Delete (Source  : in String;
                    From    : in Positive;
                    Through : in Natural)
      return String;

   procedure Delete (Source  : in out String;
                     From    : in Positive;
                     Through : in Natural;
                     Justify : in Alignment := Left;
                     Pad     : in Character := Space);

 -- String selector subprograms
   function Trim (Source : in String;
                  Side   : in Trim_End)
      return String;

   procedure Trim (Source  : in out String;
                   Side    : in Trim_End;
                   Justify : in Alignment := Left;
                   Pad     : in Character := Space);

   function Trim (Source : in String;
                  Left   : in Maps.Character_Set;
                  Right  : in Maps.Character_Set)
      return String;

   procedure Trim (Source  : in out String;
                   Left    : in Maps.Character_Set;
                   Right   : in Maps.Character_Set;
                   Justify : in Alignment := Strings.Left;
                   Pad     : in Character := Space);

   function Head (Source : in String;
                  Count  : in Natural;
                  Pad    : in Character := Space)
      return String;

   procedure Head (Source  : in out String;
                   Count   : in Natural;
                   Justify : in Alignment := Left;
                   Pad     : in Character := Space);

   function Tail (Source : in String;
                  Count  : in Natural;
                  Pad    : in Character := Space)
      return String;

   procedure Tail (Source  : in out String;
                   Count   : in Natural;
                   Justify : in Alignment := Left;
                   Pad     : in Character := Space);

-- String constructor functions

   function "*" (Left  : in Natural;
                 Right : in Character) return String;

   function "*" (Left  : in Natural;
                 Right : in String) return String;

end Ada.Strings.Fixed;

Ada.Text_IO
with Ada.Text_IO;
with Ada.Characters.Handling;

-- Lee de entrada un número entero no dejando al usuario escribir
-- caracteres que no sean dígitos. Esta versión sólo funciona
-- correctamente en Windows. Para que funcione en Linux y otros
-- sistemas Unix, hay que cambiar los valores de Intro y Back.

procedure Leer_Entero is

   -- Para Linux cambiar por ASCII.LF
   Intro : constant Character := ASCII.CR;
   -- Para Linux cambiar por ASCII.Del
   Back : constant Character := ASCII.BS;

   Char : Character;
   Fin : Boolean := False;
   Número : Natural := 0;

   -- Cadena para leer el número carácter a carácter
   -- El máximo de caracteres es Integer'Width - 1 porque no leemos signo
   Cadena_Número : String (1 .. Integer'Width - 1);

begin
  Ada.Text_IO.Put ("Escriba un número y pulse Enter: ");

  while not Fin loop

      Ada.Text_IO.Get_Immediate (Char);

      if Ada.Characters.Handling.Is_Digit (Char) then
          Número := Número + 1;
          Cadena_número(Número) := Char;
          Ada.Text_IO.Put (Char);
      elsif Char = Intro then
          Fin := True;
      elsif Número>0 and Char = Back then
          -- Si el usuario ha pulsado la tecla backspace
          -- borra el dígito escrito anteriormente
          Ada.Text_IO.Put (ASCII.BS & ' ' & ASCII.BS);
          Número:=Número-1;
      end if;

  end loop;

  Número := Integer'Value (Cadena_Número (1 .. Número));
  Ada.Text_IO.New_line;
  Ada.Text_IO.Put_Line ("Has escrito:" & Integer'Image (Número));
exception
   when Constraint_Error =>
      Ada.Text_IO.New_line;
      Ada.Text_IO.Put_Line ("Lo siento: " & Cadena_Número &
                            " es demasiado largo para almacenarse");
end Leer_Entero;

Ada.Text_IO
File_type
Ada.Text_IO
File_type
Ada.Text_IO
File_type
File_type
File_type
File_type
character
File_type
Character
Ada.Text_IO
 with Ada.Command_Line,Ada.Text_Io;
 use Ada.Command_Line,Ada.Text_Io;

 procedure Visor_texto is 

  -- Lee de un fichero de texto cuya ruta se pasa por parámetro o se pregunta
  -- explícitamente, y se visualiza por pantalla, tomando como 'estándar' una consola
  -- de 24 líneas de largo y 80 caracteres de ancho

   Caracteres_Por_Linea : constant Natural                            := 79;  
   Lineas_Por_Pantalla  : constant Natural                            := 24;  
   F                    :          File_Type;  
   Linea                :          String (1 .. Caracteres_Por_Linea);  
   Indice               :          Natural;  
   Contador             :          Natural                            := 0;  

    procedure Esperar_Tecla  is 
      C : Character;  
   begin 
      Get_Immediate(C);
   end Esperar_Tecla;

begin 
  if Argument_Count>0 then 
  -- Si hay parametros, usamos el primero como ruta del archivo
     Open(F,In_File,Argument(1));
  else 
  -- Si no hay parámetros, preguntamos explícitamente la ruta del archivo
     Put_Line("Introduzca la ruta del archivo a abrir: ");
     Get_Line(Linea,Indice);
     Open(F,In_File,Linea(1..Indice));
     New_Line(3);
  end if;

  Put_Line("-----------------------------------");
  Put_Line("- Visor de texto - " & Name(F)); 
  Put_Line("-----------------------------------");
  -- La función Name() nos devuelve la ruta del archivo
  New_Line(2);

  while not End_Of_File(F) loop     -- Leemos hasta llegar al final del fichero
     -- Si llegamos al final e intentamos leer, dará error, por lo que hay que prevenirlo
     if Contador>=Lineas_Por_Pantalla-2 then 
        New_Line;
        Put_Line("---- Presione una tecla para continuar");
        Esperar_Tecla;
        New_Line;
        Contador:=0;
     end if ;
     -- Leemos una linea desde el archivo, tomando su longitud en 'Indice' 
     -- y guardando la linea en un string
     Get_Line(F,Linea,Indice);
     -- Visualizamos la linea obtenida por pantalla, pero solo hasta la longitud obtenida
     Put_Line(Linea(1..Indice));
     Contador:=Contador+1;
  end loop ;
  Close(F);

-- Controlamos posibles errores que puede haber con ficheros
exception 
  when Name_Error=>
     New_line(2);
     Put_Line("**** Error ****");
     Put_Line("Nombre de archivo no valido");
  when Use_Error=>
     New_line(2);
     Put_Line("**** Error ****");
     Put_Line("Archivo ya abierto o inaccesible");
end Visor_texto;

Intro: character:=ASCII.Cr;  -- Windows
Intro: character:=ASCII.Lf;  -- Unix

Backspace: character:=ASCII.Bs;   -- Windows (tecla de borrar)
Backspace: character:=ASCII.Del;  -- Unix

Ada.Text_IO.Editing
with Ada.Text_IO.Editing;

procedure Ejemplo_Euros is

   type T_Precio_En_Euros is delta 0.01 digits 6;

   package Euros_IO is new Ada.Text_IO.Editing.Decimal_Output
     (Num                => T_Precio_En_Euros,
      Default_Currency   => "EUR ",
      Default_Fill       => ' ',
      Default_Separator  => '.',
      Default_Radix_Mark => ',');

   Un_Precio : constant T_Precio_En_Euros := 5873.26;
begin

   Ada.Text_IO.Put_Line
      (Euros_IO.Image
         (Item => Un_Precio,
          Pic  => Ada.Text_IO.Editing.To_Picture
                    ("#_###_###_##9.99")));
end Ejemplo_Euros;

    EUR 5.873,26

Ada.Sequential_IO
Ada.Sequential_IO
package Nombre is new Ada.Sequential_IO(Tipo);

 use Nombre

Ada.Sequential_IO
 Nombre.Open(F,Nombre.In_file,"archivo.dat");

Ada.Sequential_IO
package Pkg_integer is new Ada.Sequential_IO(Integer)
package Pkg_character is new Ada.Sequential_IO(Character);;

F: Pkg_integer.File_type;
G: Pkg_character.File_type;

File_type
File_type
File_type
Ada.Sequential_IO
with Ada.Text_IO, Ada.Sequential_IO;

 --  Ejemplo sencillo de uso Ada.Sequential_IO;
 --  Copiamos un archivo para hacer una copia de seguridad

 procedure Copiador is 

   type Byte is mod 2**8; 
   package Pkg_Byte is new Ada.Sequential_Io(Byte);

  C : Character := Ascii.Nul;  
  B : Byte;  

  Archivo_Original,  
  Archivo_Copia    : Pkg_Byte.File_Type;  
  Ruta_Entrada     : String (1 .. 32);  
  Long_Ent         : Integer            := 0;  

begin 

   Ada.Text_Io.Put_Line("Introduzca el nombre del fichero de a copiar (maximo 32 caracteres)");
   Ada.Text_Io.Get_Line(Ruta_Entrada,Long_Ent);

 --  Abrimos el fichero en modo In_file, modo lectura, 
 --  con la ruta especificada por el usuario
   Pkg_Byte.Open(Archivo_Original,Pkg_Byte.In_File,Ruta_Entrada(1..Long_Ent));

 --  Creamos un fichero del mismo nombre con terminación '.backup' 
   Pkg_Byte.Create(Archivo_Copia,Pkg_Byte.Out_File,Ruta_Entrada(1..Long_Ent) & ".backup");

  --  Copiamos el contenido del fichero original al recién creado 
  --  Nótese el uso de End_of_file para prevenir la lectura de final de fichero 
   while not Pkg_Byte.End_Of_File(Archivo_Original) loop 
      Pkg_Byte.Read(Archivo_Original,B);
      Pkg_Byte.Write(Archivo_Copia,B);
   end loop ;

 --  Importante: ¡No hay que olvidarse de cerrar los ficheros cuando no los usemos! 
   Pkg_Byte.Close(Archivo_Original);
   Pkg_Byte.Close(Archivo_Copia);

   Ada.Text_Io.Put_Line("Operacion realizada con exito");
   Ada.Text_Io.Put_Line("Presione cualquier tecla para finalizar");
   Ada.Text_Io.Get_Immediate(C);

exception 
   when Pkg_Byte.Name_Error=>
      Ada.Text_Io.Put_Line("Error: Nombre de archivo o ruta incorrectos");
   when Pkg_Byte.Use_Error=>
      Ada.Text_Io.Put_Line("Error: El archivo ya esta abierto");
end Copiador;

 with Ada.Text_IO, Ada.Integer_Text_IO, Ada.Sequential_IO;

 --  Ejemplo avanzado de uso Ada.Sequential_IO;
 --  Programa de 'cifrado' César
 --  Leemos de un fichero, hacemos un desplazamiento mediante    
 --  una contraseña (método César) y escribimos en otro fichero.

 -- Evidentemente la seguridad es casi nula, basta ir probando las
 -- 255 posibilidades para sacarlo. Y si cifras dos veces consecutivas
 -- de forma que sumen 256 también se saca.

procedure Cesar is 

  type Byte is mod 2**8; 
  package Pkg_Byte is new Ada.Sequential_Io(Byte);

  C : Character := Ascii.Nul;  
  B : Byte;  

  Archivo_Entrada,  
  Archivo_Salida  : Pkg_Byte.File_Type;  
  Ruta_Entrada,  
  Ruta_Salida     : String (1 .. 32);  
  Password,  
  Long_Ent,  
  Long_Sal,  
  Aux             : Integer            := 0;  

begin 

   while C/='c' and C/='d' loop 
      Ada.Text_Io.Put_Line("Cifrar (c) o Descifrar (d)?");
      Ada.Text_Io.Get_Immediate (C);
      if C/='c' and C/='d' then 
         Ada.Text_Io.New_Line;
         Ada.Text_Io.Put_Line("Error:Pulse la C o la D");
      end if;
   end loop;

  Ada.Text_Io.Put("Ha elegido: ");
  if C='c' then
     Ada.Text_Io.Put("Cifrar");
     Ada.Text_Io.New_Line(2);
  else
     Ada.Text_Io.Put("Descifrar");
     Ada.Text_Io.New_Line(2);
  end if;

  Ada.Text_Io.Put_Line("Introduzca el nombre del fichero de entrada (maximo 32 caracteres)");
  Ada.Text_Io.Get_Line(Ruta_Entrada,Long_Ent);
  Pkg_Byte.Open(Archivo_Entrada,Pkg_Byte.In_File,Ruta_Entrada(1..Long_Ent));

  Ada.Text_Io.Put_Line("Introduzca el nombre del fichero de salida (maximo 32 caracteres)");
  Ada.Text_Io.Put_Line("Ojo, sobreescribira el fichero sin preguntar!");
  Ada.Text_Io.Get_Line(Ruta_Salida,Long_Sal);
  Pkg_Byte.Create(Archivo_Salida,Pkg_Byte.Out_File,Ruta_Salida(1..Long_Sal));

  while Password<1 or Password>255 loop
     Ada.Text_Io.Put_Line("Elija un password (numero del 1 al 255)");
     Ada.Integer_Text_Io.Get(Password);
     if Password<1 or Password>255 then
        Ada.Text_Io.New_Line;
        Ada.Text_Io.Put_Line("Error: El valor no es correcto. Debe estar entre 1 y 255");
     end if;
  end loop;

  while not Pkg_Byte.End_Of_File(Archivo_Entrada) loop
     Pkg_Byte.Read(Archivo_Entrada,B);
     if C='c' then
        Aux:=(Integer(B)+Password) mod 256;
     else
        Aux:=(Integer(B)-Password) mod 256;
     end if;
     Pkg_Byte.Write(Archivo_Salida,Byte(Aux));
  end loop;

  Pkg_Byte.Close(Archivo_Entrada);
  Pkg_Byte.Close(Archivo_Salida);

  Ada.Text_Io.Put_Line("Operacion realizada con exito");
  Ada.Text_Io.Put_Line("Presione cualquier tecla para finalizar");
  Ada.Text_Io.Get_Immediate(C);

exception
  when Pkg_Byte.Name_Error=>
     Ada.Text_Io.Put_Line("Error: Nombre de archivo o ruta incorrectos");
  when Pkg_Byte.Use_Error=>
     Ada.Text_Io.Put_Line("Error: El archivo ya esta abierto");
  when Ada.Integer_Text_IO.Data_Error=>
     Ada.Text_Io.Put_Line("Error: La contraseña debe estar entre 1 y 255");
end Cesar;

with Ada.Text_IO;
with Ada.Command_Line; use Ada.Command_Line; 

-- Imprime los argumentos pasados por línea de comandos

procedure Imprimir_Argumentos is

begin

  Ada.Text_IO.Put_Line ("Imprimiendo argumentos pasados a " &
      Command_Name & '.');

  for I in 1 .. Argument_Count loop

      Ada.Text_IO.Put_Line
        ("Argumento nº" & Integer'Image (I) & ": " &
         Argument (I));

  end loop;

  Set_Exit_Status (Success);

exception
   when others =>
      Set_Exit_Status (Failure);
end Imprimir_Argumentos;

package Ada.Command_Line is
  pragma Preelaborate(Command_Line);

  function Argument_Count return Natural;

  function Argument (Number : in Positive) return String;

  function Command_Name return String;

  type Exit_Status is implementation-defined integer type;

  Success : constant Exit_Status;
  Failure : constant Exit_Status;

  procedure Set_Exit_Status (Code : in Exit_Status);

private
  ... -- not specified by the language
end Ada.Command_Line;

Copyright (C) 2000,2001,2002  Free Software Foundation, Inc.
51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.

`abort`	`else`	`new`	`return`
`abs`	`elsif`	`not`	`reverse`
`abstract`	`end`	`null`
`accept`	`entry`		`select`
`access`	`exception`	`of`	`separate`
`aliased`	`exit`	`or`	`subtype`
`all`		`others`
`and`	`for`	`out`	`tagged`
`array`	`function`		`task`
`at`		`package`	`terminate`
	`generic`	`pragma`	`then`
`begin`	`goto`	`private`	`type`
`body`		`procedure`
	`if`	`protected`	`until`
`case`	`in`		`use`
`constant`	`is`	`raise`
		`range`	`when`
`declare`	`limited`	`record`	`while`
`delay`	`loop`	`rem`	`with`
`delta`		`renames`
`digits`	`mod`	`requeue`	`xor`
`do`

Clase	Nombre	Fórmula	Sintáxis Ada
Lógicos	Conjunción	$x\land y$	`and`
	Disyunción inclusiva	$x\lor y$	`or`
	Disyunción exclusiva	$(x\land {\bar {y}})\lor ({\bar {x}}\land y)$	`xor`
Relacionales	Igualdad	$x=y$	`=`
	Desigualdad	$x\neq y$	`/=`
	Menor que	$x<y$	`<`
	Menor o igual que	$x\leq y$	`<=`
	Mayor que	$x>y$	`>`
	Mayor o igual que	$x\geq y$	`>=`
Aditivo unario	Identidad	$+x$	`+`
	Negación	$-x$	`-`
Aditivo binario	Suma	$x+y$	`+`
	Resta	$x-y$	`-`
Concatenación	Concatenación		`&`
Multiplicativo	Multiplicación	$x\times y$	`*`
	División	${\begin{matrix}{\frac {x}{y}}\end{matrix}}$	`/`
	Módulo	$x{\bmod {y}}$	`mod`
	Resto		`rem`
De máxima precedencia	Exponenciación	$x^{y}$	`**`
	Negación	$\lnot x$	`not`
	Valor absoluto	$\|x\|$	`abs`

Tipo formal	Instanciable con
`type T is private;`	Cualquier tipo con operador de igualdad y asignación definidos
`type T (D : TD) is limited private;`	Cualquier tipo con discriminante de tipo TD
`type T (<>) is private;`	Cualquier tipo con cualquier discriminante
`type T is limited private;`	Cualquier tipo (sea limitado o no)
`type T is (<>);`	Cualquier tipo discreto
`type T is range <>;`	Cualquier tipo entero con signo
`type T is delta <>;`	Cualquier tipo de coma fija
`type T is digits <>;`	Cualquier tipo de coma flotante
`type T is array (I) of E;`	Cualquier tipo array con índice I y tipo de elementos E (I y E podrían ser a su vez otros parámetros formales)
`type T is access O;`	Cualquier tipo puntero que apunte a objetos de tipo O (O podría ser a su vez otro parámetro formal)

Programación en Ada/Texto completo

Programación en Ada

Prólogo

Acerca de este libro

Créditos y licencia

Introducción

Características principales

Historia

Enlaces externos

Manual de referencia

Instalación de un compilador

GNAT

GNAT GPL Edition: Ada 2005

GNAT 3.15p precompilado

Paquetes precompilados formando parte de distribuciones

Mac OS X

GNU

SuSE

Debian GNU/Linux

Gentoo GNU/Linux

Mandrake

Windows

MinGW

Cygwin

MS-DOS

Solaris 8, 9, 10 sobre SPARC y x86

Compilarlo uno mismo

Aonix ObjectAda

Enlaces

Un ejemplo básico: Hola Mundo

Abreviando

Compilación

Elementos del lenguaje

Alfabeto

Componentes léxicos

Identificadores

Números

Literales de tipo carácter

Cadenas de caracteres

Delimitadores

Comentarios

Palabras reservadas

Manual de referencia de Ada

Tipos

Clasificación de tipos

Declaración de tipos

Algunos atributos aplicables a tipos

Subtipos

Superar una ambigüedad

Tipos avanzados

Manual de referencia de Ada

Enteros

Tipos enteros con signo

Ejemplo

Tipos enteros con signo predefinidos

Enteros modulares

Manual de referencia de Ada

Enumeraciones

Operadores y atributos predefinidos

Literales carácter

Tipo boolean

Subtipos de enumeración

Manual de referencia de Ada

Coma flotante

Manual de referencia de Ada

Coma fija

Coma fija decimal

Coma fija ordinaria

Manual de referencia Ada

Arrays

Declaración de arrays

Sintáxis básica

Con subrango conocido

Con un subrango desconocido

Con elementos aliased

Uso de arrays

Ejemplo de uso

Manual de referencia de Ada

Strings

Manual de refencia de Ada