Corps maquettes de la première version

Cette version du menu comporte une fonction Choix_Utilisateur qui renvoie successivement tous les choix possibles, puis déclenche une annulation de commande, enfin lève l'exception Program_Error de façon à terminer le programme (le programme en vraie grandeur ne se termine jamais, aussi n'y a-t-il rien de prévu à cet effet)... ce qui permet également de tester notre traite-exception de sécurité.

with ADPT; use ADPT;
package body Menu is
	Terminer   : Boolean := False;
	Annuler    : Boolean := False;
	A_Renvoyer : Produit := Produit'First;
	procedure Activer is
	begin
		ADPT_Action("Activation du menu");
	end Activer;
	function Choix_Consommateur return Produit is
	begin
		ADPT_Action("Choix du produit");
		if Terminer then
			raise Program_Error;
		end if;
		if Annuler then
			Terminer := True;
			Annulation.Demande;  -- Provoque l'avortement
		end if;
		if A_Renvoyer = Produit'Last then
			Annuler := True;
			return A_Renvoyer;
		end if;
		A_Renvoyer := Produit'Succ(A_Renvoyer);
		return Produit'Pred(A_Renvoyer);
	end Choix_Consommateur;
	procedure Invalider (Le_produit : Produit) is
	begin
		ADPT_Action("Invalidation du produit " &
		            Produit'Image(Le_Produit));
	end Invalider;
	procedure Revalider (Le_produit : Produit) is
	begin
		ADPT_Action("Revalidation du produit " &
		            Produit'Image(Le_Produit));
	end Revalider;
	protected body Annulation is
		entry Signalement when Ouverte is
		begin
			if Signalement'Count = 0 then
				Ouverte := False;
			end if;
		end Signalement;
		procedure Demande is
		begin
			if Signalement'Count > 0 then
				Ouverte := True;
			end if;
		end Demande;
	end  Annulation;
end Menu;

with ADPT; use ADPT;
package body Monnayeur is
	procedure Activer is
	begin
		ADPT_Action("Activation du monnayeur");
	end Activer;
	procedure Bloquer is
	begin
		ADPT_Action("Bloquer le monnayeur");
	end Bloquer;
	procedure Attendre(Pour_Produit : Produit) is
	begin
		ADPT_Action("Attente du montant suffisant");
	end Attendre;
	function  Montant_Introduit return Argent  is
	begin
		return 5.0;
	end Montant_Introduit;
	procedure Rendre_Monnaie(Du_produit: Produit) is
	begin
		ADPT_Action("Rendre monnaie sur " &
		            Produit'Image(Du_Produit));
	end Rendre_Monnaie;
	procedure Rembourser is
	begin
		ADPT_Action("Remboursement");
	end Rembourser;
end Monnayeur;

with ADPT; use ADPT;
package body Tarif is
	function Le_Prix (De: Produit) return Argent is
	begin
		return 2.0;
	end Le_Prix;
end Tarif;

Corps du compteur générique

package body Compteur_Protégé_Générique is
	protected Compteur is
		procedure Incrémenter (De : A_Compter);
		function  Valeur_Courante return A_Compter;
		procedure Remise_A_Zéro;
		entry Attendre(Montant : A_Compter);
	private
		entry Faire_La_Queue;
		Accumulateur    : A_Compter := Valeur_Nulle;
		Montant_Attendu : A_Compter := Valeur_Nulle;
	end Compteur;
	procedure Attendre(Valeur : A_Compter) is
	begin
		Compteur.Attendre(Valeur);
	end;
	procedure Incrémenter (De : A_Compter) is
	begin
		Compteur.Incrémenter(De);
	end;
	function  Valeur_Courante return A_Compter is
	begin
		return Compteur.Valeur_Courante;
	end;
	procedure Remise_A_Zéro is
	begin
		Compteur.Remise_A_Zéro;
	end;
	protected body Compteur is
		entry Faire_La_Queue 
			when not (Accumulateur < Montant_Attendu) is
		begin
			null;
		end Faire_La_Queue;
		entry Attendre(Montant : A_Compter)
			when Faire_La_Queue'Count = 0 is
		begin
			Montant_Attendu := Montant;
			requeue Faire_La_Queue with abort;
		end Attendre;
		procedure Incrémenter (De : A_Compter) is
		begin
			Accumulateur := Accumulateur + De;
		end;
		function  Valeur_Courante return A_Compter is
		begin
			return Accumulateur;
		end;
		procedure Remise_A_Zéro is
		begin
			Accumulateur := Valeur_Nulle;
		end;
	end Compteur;
end Compteur_Protégé_Générique;

Corps maquettes pour le monnayeur de deuxième niveau

with ADPT; use ADPT;
package body Clapet is
	procedure Ouvrir is
	begin
		ADPT_Action("Ouvrir le clapet");
	end Ouvrir;
	procedure Fermer is
	begin
		ADPT_Action("Fermer le clapet");
	end Fermer;
end Clapet;

package body Monnayeur.Définition_Pièces is
	function Répartir(Montant : Argent) 
		return Répartition_Pièces is
		Répartition : Répartition_Pièces := (others => 0);
		Restant     : Argent := Montant;
	begin
		for Type_Pièce in reverse Pièces loop
			while Restant >= Valeurs (Type_Pièce) and
			      Nombre_De_Pièces ( Magasin(Type_Pièce)) >
			      Répartition (Type_Pièce)
			loop
				Répartition(Type_Pièce) :=
					Répartition(Type_Pièce) + 1;
				Restant := Restant - Valeurs(Type_Pièce);
			end loop;
		end loop;
		if Restant > 0.0 then
			raise Rendu_Impossible;
		else
			return Répartition;
		end if;
	end Répartir;
end Monnayeur.Définition_Pièces;

Corps des distributeurs d'ingrédients

with ADPT;
package body Unité_Fabrication.Distributeur_Poudre is
	procedure Servir_Dose(De : access Instance) is
		use ADPT;
	begin
		ADPT_ACTION("Je distribue poudre : " &
		            Integer_Address'IMAGE(De.Adresse));
	end Servir_Dose;
end Unité_Fabrication.Distributeur_Poudre;

with ADPT;
package body Unité_Fabrication.Distributeur_Liquide is
	procedure Servir_Dose(De : access Instance) is
		use ADPT;
	begin
		ADPT_ACTION("Je distribue liquide : " &
		            Integer_Address'IMAGE(De.Adresse) &
		            " volume " &
		            Volume_Livré'Image(De.Volume) &
		            " cl");
	end Servir_Dose;
end Unité_Fabrication.Distributeur_Liquide;

Le paquetage ADPT

Spécification

package ADPT is

	--------------------------- Type complètement indéfini
	type ADPT_Type is private;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)
		return ADPT_Type;
	ADPT_Valeur : constant ADPT_Type;

	--------------------------- Type Enumératif
	type ADPT_Type_Enuméré is (ADPT_Valeur_Enumérée);
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)      
		return ADPT_Type_Enuméré;

	--------------------------- Type discret
	type ADPT_Type_Discret is new ADPT_Type_Enuméré;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)      
		return ADPT_Type_Discret;
	ADPT_Valeur_Discrète : constant ADPT_Type_Discret;

	--------------------------- Type entier
	type ADPT_Type_Entier is range 0..1;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)      
		return ADPT_Type_Entier;
	ADPT_Valeur_Entière : constant ADPT_Type_Entier;

	--------------------------- Type flottant
	type ADPT_Type_Flottant is new FLOAT;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)      
		return ADPT_Type_Flottant;
	ADPT_Valeur_Flottante : constant ADPT_Type_Flottant;

	--------------------------- Type fixe
	type ADPT_Type_Fixe is new DURATION;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)      
		return ADPT_Type_Fixe;
	ADPT_Valeur_Fixe : constant ADPT_Type_Fixe;

	--------------------------- Type tableau
	type ADPT_Type_Tableau is array(ADPT_Type_Discret)
	                          of ADPT_Type;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)
		return ADPT_Type_Tableau;
	ADPT_Valeur_Tableau : constant ADPT_Type_Tableau;

	--------------------------- Type article
	type ADPT_Type_Article is
		record
			ADPT_Element : ADPT_Type;
		end record;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)
		return ADPT_Type_Article;
	ADPT_Valeur_Article : constant ADPT_Type_Article;

	--------------------------- Type accès
	type ADPT_Type_Accès is access ADPT_Type;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)
		return ADPT_Type_Accès;
	ADPT_Valeur_Accès : constant ADPT_Type_Accès;

	--------------------------- Type étiqueté
	type ADPT_Type_Etiqueté is tagged
		record
			ADPT_Element : ADPT_Type;
		end record;
	function ADPT_Fonction(Info  : String   := "";
	                       Durée : Duration := 0.0)
		return ADPT_Type_Etiqueté;
	ADPT_Valeur_Etiquetée : constant ADPT_Type_Etiqueté;

	--------------------------- Type étiqueté abstrait
	type ADPT_Type_Etiqueté_Abstrait is
		abstract tagged null record;
	-- Les types abstraits n'ont pas de valeurs

	--------------------------- Autres déclarations
	ADPT_Condition : constant BOOLEAN := False;
	ADPT_Exception : exception;
	procedure ADPT_Procédure(Info  : String   := "";
	                         Durée : Duration := 0.0);
	procedure ADPT_Actions  (Info  : String   := "";
	                         Durée : Duration := 0.0);

	--------------------------- Ajustement du comportement
	type ADPT_Comportement is (Ignorer, Tracer, Piéger);
	ADPT_Comportement_Courant: ADPT_Comportement := Ignorer;

private
	type ADPT_Type is range 0..0;
	ADPT_Valeur           : constant ADPT_Type := 0;
	ADPT_Valeur_Discrète  : constant ADPT_Type_Discret  
		:= ADPT_Valeur_Enumérée;
	ADPT_Valeur_Entière   : constant ADPT_Type_Entier
		:= 0;
	ADPT_Valeur_Flottante : constant ADPT_Type_Flottant
		:= 0.0;
	ADPT_Valeur_Fixe      : constant ADPT_Type_Fixe
		:= 0.0;
	ADPT_Valeur_Tableau   : constant ADPT_Type_Tableau
		:= (ADPT_Valeur_Discrète => ADPT_Valeur);
	ADPT_Valeur_Article   : constant ADPT_Type_Article
		:= (ADPT_Element => ADPT_Valeur);
	ADPT_Valeur_Etiquetée : constant ADPT_Type_Etiqueté
		:= (ADPT_Element => ADPT_Valeur);
	ADPT_Valeur_Accès     : constant ADPT_Type_Accès
		:= new ADPT_Type'(ADPT_Valeur);
end ADPT;

Corps

with Ada.Text_IO;
package body ADPT is

	ADPT_Exception_Cachée : exception;

	procedure Message (Nom   : String; Info  : String;
                     Durée : Duration) is
		use Ada.Text_IO;
	begin
		delay Durée;
		case ADPT_Comportement_Courant is
		when Ignorer =>
			null;
		when Tracer =>
			if Info = "" then
				Put_Line ("*** Appel de " & Nom & " ***");
			else
				Put_Line ("*** Appel de " & Nom & " : " & Info);
			end if;
		when Piéger =>
			raise ADPT_Exception_Cachée;
		end case;
	end Message;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type is
	begin
		Message("ADPT_Fonction (type indéfini)", Info, durée);
		return ADPT_Valeur;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Enuméré is
	begin
		Message("ADPT_Fonction (type énuméré)", Info, durée);
		return ADPT_Valeur_Enumérée;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Discret is
	begin
		Message("ADPT_Fonction (type discret)", Info, durée);
		return ADPT_Valeur_Discrète;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Entier is
	begin
		Message("ADPT_Fonction (type entier)", Info, durée);
		return ADPT_Valeur_Entière;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Flottant is
	begin
		Message("ADPT_Fonction (type flottant)", Info, durée);
		return ADPT_Valeur_Flottante;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Fixe is
	begin
		Message("ADPT_Fonction (type fixe)", Info, durée);
		return ADPT_Valeur_Fixe;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return  ADPT_Type_Tableau is
	begin
		Message("ADPT_Fonction (type tableau)", Info, durée);
		return ADPT_Valeur_Tableau;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Article is
	begin
		Message("ADPT_Fonction (type article)", Info, durée);
		return ADPT_Valeur_Article;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Accès is
	begin
		Message("ADPT_Fonction (type accès)", Info, durée);
		return ADPT_Valeur_Accès;
	end ADPT_Fonction;

	function ADPT_Fonction (Info  : String   := "";
	                        Durée : Duration := 0.0)
		return ADPT_Type_Etiqueté is
	begin
		Message("ADPT_Fonction (type étiqueté)", Info, durée);
		return ADPT_Valeur_Etiquetée;
	end ADPT_Fonction;

	procedure ADPT_Procédure (Info  : String   := "";
	                          Durée : Duration := 0.0) is
	begin
		Message("procédure à définir", Info, Durée);
	end ADPT_Procédure;

	procedure ADPT_Actions (Info  : String   := "";
	                        Durée : Duration := 0.0) is
	begin
		Message("action à définir", Info, Durée);
 	end ADPT_Actions;

end ADPT;

Modèle de fiche de composant

Nom de base de l'unité Ada
Identification Cette rubrique résume les éléments communs à toutes les implémentations et à toutes les variantes. Elle doit permettre de décider rapidement si le composant est susceptible de répondre au besoin. Description Brève description du rôle du composant logiciel. Mots-clés Mots clés référencés dans la base de donnée de composants logiciels et utilisés pour l'index. Caractérisation Unité: Paquetage, procédure, fonction, générique. Genre: Machine abstraite, type de donnée abstrait... Liaisons: Indépendant, surcouche, encapsulation, famille... Variantes Liste des variantes disponibles, avec taxonomie Booch/Berard. Limites et contraintes d'implémentations pour chaque variante. Disponibilité Systèmes de compilation: (Compilateur, hôte, cible) sous lesquels le composant est disponible (compilé, validé, testé). Matrice des versions (Variantes, systèmes). Accès: Pour chaque système de compilation: Disponibilité en source ou sous forme de sous-bibliothèque. Contraintes d'accès (droits d'accès système nécessaires, composant réservé, copyright et droits d'accès, run-time éventuels, autorisations nécessaires). Procédures à suivre pour accéder au composant (information au gestionnaire de composants). Historique Dates des principales releases. Nombre d'utilisations précédentes. Préciser si en cours de développement, bêta-test.
Spécifications Eléments génériques et ajustement de comportement Description des éléments apparaissant en paramètres génériques. Rôle et invariants supposés. Conditions de bon fonctionnement. Unités séparées redéfinissables par l'utilisateur. Eléments principaux Spécification Ada des éléments indépendants de la variante, par groupe d'éléments logiquement reliés. Spécification abstraite du rôle de chacun des éléments. Invariants. Vérifications effectuées. Exceptions susceptibles d'être levées. Eléments annexes Idem, pour les éléments supplémentaires dépendant de la variante.
Implémentations Eléments de l'implémentation importants pour l'utilisateur. Elaboration Pour chaque variante: pragma Elaborate_All (ou Elaborate) nécessaires au bon fonctionnement du composant. Toutes dépendances à l'initialisation. Accès physique Pour chaque système de compilation: Localisation physique du composant (machine, répertoire, nom de fichier ou d'unité si plusieurs variantes). Toutes informations nécessaires à l'utilisation pratique du composant Algorithme Précisions sur l'algorithme utilisé, s'il est important pour l'utilisateur. Eléments sensibles utilisés Pour chaque variante: préciser si l'implémentation utilise les points flottants (à cause de la nécessité parfois de la présence d'un co-processeur), le tasking, l'allocation dynamique. Performances Pour chaque variante: complexité de l'algorithme. Conditions d'exécution du test standard. Temps d'exécution du programme de test standard en configuration nominale, par variante et système de compilation. Autres informations Toutes autres informations nécessaires: utilisation d'éléments non standard du langage pouvant présenter un risque de changement en cas de modification du système de compilation. Particularités et justification d'exceptions à la sémantique générale pour certaines implémentations. Dépendances particulières à l'implémentation.