[Ada]Modélisation particulière du système général, avec Ada.

Modélisation particulière du système général, avec Ada. [Ada] - Ada - Programmation

Marsh Posté le 22-01-2013 à 23:06:05    

Bonjour, j'ai un problème avec Ada, un autre.
 
Le compilateur me dit :

gcc-4.4 -c -Isrc/ -Isrc/lib -I- src/main.adb
main.adb:37:70: expect valid subtype mark to instantiate "Affector_Type"
main.adb:37:70: instantiation abandoned
gnatmake: "src/main.adb" compilation error


 
Apparemment le type fournit n'est pas le bon, mais pourtant, mais quand même, que puis-je y faire ?
 
Le paquet de sources : http://80.15.188.151/dev/EtherAda/EtherAda.tar.gz
 
Les sources du main concerné :

Code :
  1. with Libmy;
  2. with Libmy.Virtual;
  3. with Libmy.Virtual.Objects;             use Libmy.Virtual.Objects;
  4. with Libmy.Virtual.Objects.Generic_Elements;
  5. with Libmy.Virtual.Activities;
  6. procedure Main is
  7.  
  8.   type String_Access is access all String;
  9.  
  10.   type String_Element_Type is new Object_Type with
  11.      record
  12.         Value : String_Access;
  13.      end record;
  14.  
  15.   function Identity(Element : in String_Element_Type) return String_Element_Type is
  16.   begin
  17.      return Element;
  18.   end Identity;
  19.  
  20.   Default_String_Element : constant String_Element_Type := (Object_Type With Value => new String ' ("" ));
  21.   package String_Elements is
  22.      new Libmy.Virtual.Objects.Generic_Elements(String_Element_Type,
  23.                                                 Default_String_Element,
  24.                                                 Identity);
  25.  
  26.   procedure Affection (String_Element : in out String_Element_Type'class;Value : in String_Element_Type'class) is
  27.   begin
  28.      String_Element := Value;
  29.   end Affection;
  30.  
  31.   function Effection (String_Element : in String_Element_Type) return String_Element_Type'class is
  32.   begin
  33.      return String_Element;
  34.   end Effection;
  35.  
  36.   package String_Acctivity is new Libmy.Virtual.Activities(String_Element_type,
  37.                                                            Affection'Access,
  38.                                                            Effection'Access);
  39.  
  40. begin
  41.  
  42.   null;
  43. end Main;


 
La paquet générique en instanciation :

Code :
  1. with Libmy.Virtual.Objects;
  2. use Libmy.Virtual.Objects;
  3. generic
  4.   type Active_Object_Type is new Object_Type with private;
  5.   type Affector_Type is access  procedure (Active_Object : in out Active_Object_Type'class; Value : in Active_Object_Type'class);
  6.   type Effector_type is access  function (Active_Object : in Active_Object_Type) return Active_Object_Type'Class;
  7. package Libmy.Virtual.Activities is


 
 
Ce problème est le premier, ou pas d'un longue liste à venir sur la modélisation du système générale en particulier.


Message édité par Profil supprimé le 22-01-2013 à 23:06:35
Reply

Marsh Posté le 22-01-2013 à 23:06:05   

Reply

Marsh Posté le 23-01-2013 à 00:04:04    

Résolut après quelque modification.
 
Je vous met là, le main corrigé et augmenté.
 

Code :
  1. with Ada.Text_Io;
  2. use Ada;
  3.  
  4. with Libmy;
  5. with Libmy.Virtual;
  6. with Libmy.Virtual.Objects;             use Libmy.Virtual.Objects;
  7. with Libmy.Virtual.Objects.Generic_Elements;
  8. with Libmy.Virtual.Activities;
  9. procedure Main is
  10.  
  11.   type String_Access is access all String;
  12.  
  13.   type String_Element_Type is new Object_Type with
  14.      record
  15.      Value : String_Access;
  16.      end record;  
  17.  
  18.   function Identity(Element : in String_Element_Type) return String_Element_Type is
  19.   begin
  20.      return Element;
  21.   end Identity;
  22.  
  23.   Default_String_Element : aliased constant String_Element_Type := (Object_Type With Value => new String ' ("World " ));  
  24.   package String_Elements is
  25.      new Libmy.Virtual.Objects.Generic_Elements(String_Element_Type,
  26.                          Default_String_Element,
  27.                          Identity);
  28.      
  29.   type Affector_Type is access  
  30.     procedure (String_Element : in out String_Element_Type'class;
  31.         Value : in String_Element_Type'class);
  32.  
  33.   type Effector_type is access
  34.     function (String_Element : in String_Element_Type) return String_Element_Type;
  35.  
  36.   procedure Affection (String_Element : in out String_Element_Type'class;
  37.             Value : in String_Element_Type'class) is
  38.   begin      
  39.      String_Element := Value;
  40.   end Affection;
  41.  
  42.   function Effection (String_Element : in String_Element_Type) return String_Element_Type is
  43.   begin
  44.      return String_Element;
  45.   end Effection;
  46.  
  47.   package Strings_Activity is new Libmy.Virtual.Activities(String_Element_Type,
  48.                                 Affector_type,
  49.                                 Effector_type);
  50.  
  51.   Hello : aliased String_Element_Type := (Object_type with Value => (new String ' ("hello " )));
  52.  
  53.   Message : aliased String_Element_Type;
  54.  
  55.   Une_Chaine_Active : Strings_Activity.Activity_Type(Hello'Access);      
  56.  
  57. begin
  58.  
  59.   Une_Chaine_Active.Affect(Affection'Access, Hello);
  60.   Une_Chaine_Active.Effect(Effection'Access, Message);
  61.   Text_Io.Put(Message.Value.all);
  62.   Une_Chaine_Active.Affect(Affection'Access, Default_String_Element);
  63.   Une_Chaine_Active.Effect(Effection'Access, Message);
  64.   Text_Io.Put(Message.Value.all);
  65.  
  66. end Main;


 
 

root@Muse:/home/root/EtherAda# emacs
root@Muse:/home/root/EtherAda# make
gnatmake -o bin/EtherAda -D obj src/main.adb -aIsrc/lib
gcc-4.4 -c -Isrc/ -Isrc/lib -I- -o obj/main.o src/main.adb
gcc-4.4 -c -Isrc/ -Isrc/lib -I- -o obj/libmy.o /home/root/EtherAda/src/lib/libmy.ads
gcc-4.4 -c -Isrc/ -Isrc/lib -I- -o obj/libmy-virtual.o /home/root/EtherAda/src/lib/libmy-virtual.ads
gcc-4.4 -c -Isrc/ -Isrc/lib -I- -o obj/libmy-virtual-activities.o /home/root/EtherAda/src/lib/libmy-virtual-activities.adb
gcc-4.4 -c -Isrc/ -Isrc/lib -I- -o obj/libmy-virtual-objects.o /home/root/EtherAda/src/lib/libmy-virtual-objects.ads
gcc-4.4 -c -Isrc/ -Isrc/lib -I- -o obj/libmy-virtual-objects-generic_elements.o /home/root/EtherAda/src/lib/libmy-virtual-objects-generic_elements.adb
gnatbind -aOobj -aIsrc/lib -x obj/main.ali
gnatlink obj/main.ali -o bin/EtherAda
root@Muse:/home/root/EtherAda# ./bin/EtherAda  
hello World  
root@Muse:/home/root/EtherAda#


 
 
Pourquoi s'embêter quand on peut faire complexe.

Reply

Marsh Posté le 23-01-2013 à 05:57:43    

Je me suis lamentablement planté à la précédente descente aux enfers.
 
 
Je me reprends avec un truc plus simple en objet, mais la fin est la même.
 

Code :
  1. with Ada.Finalization;
  2. package Virtual is
  3.   type Virtual_Type is abstract new Ada.Finalization.Limited_Controlled with null record;    
  4. end Virtual;
  5. with System.Storage_Elements;
  6. use System;
  7.  
  8. with Virtual;
  9. generic
  10.  
  11.   Max_Element : Storage_Elements.Storage_Count := 2;
  12.   type object_Type is new Virtual.Virtual_Type with private;
  13. package Objects is
  14.   type Object_Access is access all Object_Type'Class;
  15. end Objects;
  16.    
  17.    
  18. with Virtual;
  19. with Objects;
  20. package Alphabetic is
  21.  
  22.   type Alphabetic_Type is abstract new Virtual.Virtual_type with private;
  23.  
  24.   procedure Initialize(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean);
  25.   procedure Adjust(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean);
  26.   procedure Finalize(Alphabetic : in out Alphabetic_Type'Class);
  27. private  
  28.  
  29.   type String_Access is access all String;
  30.   type String_Handle_Type Is new Virtual.Virtual_Type with
  31.      record
  32.      Value : String_Access;
  33.      end record;
  34.      
  35.   package Strings_Object is new Objects(2, String_Handle_Type);
  36.      
  37.   type Alphabetic_Type is abstract new Virtual.Virtual_type with
  38.      record
  39.      Object : Strings_Object.Object_Access;
  40.      end record;
  41. end Alphabetic;
  42. with Ada.Text_Io;
  43. use Ada;
  44. package body Alphabetic is
  45.  
  46.  
  47.   procedure Initialize(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean) is
  48.   begin
  49.      if not Hidden then
  50.      Alphabetic.Object := new String_handle_Type ' (Virtual.Virtual_type with Value => new String ' (Text_Io.Get_Line));    
  51.      end if;
  52.   end Initialize;
  53.  
  54.   procedure Adjust(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean) is
  55.   begin
  56.      null;
  57.   end Adjust;
  58.  
  59.   procedure Finalize(Alphabetic : in out Alphabetic_Type'Class) is
  60.   begin
  61.      null;
  62.   end Finalize;
  63. end Alphabetic;
  64.  
  65.  
  66. with Alphabetic;
  67.  
  68. procedure Main is
  69.  
  70.   package Info is      
  71.      
  72.      type Info_Type(Auto   : Boolean;Hidden : Boolean) is new Alphabetic.Alphabetic_Type with null record;
  73.   private                
  74.      
  75.      procedure Initialize(Info : in out Info_Type);
  76.      procedure Adjust(Info : in out Info_Type);
  77.      procedure Finalize(Info : in out Info_Type);                  
  78.   end Info;
  79.  
  80.   package body Info is      
  81.      
  82.      procedure Initialize(Info : in out Info_Type) is
  83.      begin
  84.      if Info.Auto then
  85.         Alphabetic.Alphabetic_Type(Info).Initialize(Info.Hidden);
  86.      end if;
  87.      end Initialize;
  88.      
  89.      procedure Adjust(Info : in out Info_Type) is
  90.      begin
  91.      Alphabetic.Alphabetic_Type(Info).Adjust(Info.Hidden);
  92.      end Adjust;
  93.      
  94.      procedure Finalize(Info : in out Info_Type) is
  95.      begin
  96.      Alphabetic.Alphabetic_Type(Info).Finalize;
  97.      end Finalize;
  98.   end Info;
  99.  
  100.  
  101.  
  102.   Auto_visible : Info.Info_Type(True, False);
  103.  
  104.  
  105. begin
  106.  
  107.   null;
  108. end Main;


 
Voilà, bienvenu à tous ceux et celles qui pourrons m'aider dans la quête du graal.  [:caudacien:3]

Reply

Marsh Posté le 23-01-2013 à 08:46:00    

Bonjour bonjour, j'ai un problème,
 
Je vous poste les sources :

Code :
  1. with Ada.Text_Io;
  2. use Ada;
  3. with Virtual;
  4. with Alphabetic;
  5. with Ada.Finalization;
  6. use Ada.Finalization;
  7. procedure Main is
  8.  
  9.   package Info is      
  10.      
  11.      type Info_Type(Auto   : Boolean;Hidden : Boolean) is new Alphabetic.Alphabetic_Type with null record;
  12.  
  13.      
  14.      procedure Initialize(Info : in out Info_Type);
  15.      procedure Adjust(Info : in out Info_Type);
  16.      procedure Finalize(Info : in out Info_Type);                  
  17.   end Info;
  18.  
  19.   package body Info is      
  20.      
  21.      Procedure Initialize(Info : in out Info_Type) is
  22.      begin
  23.      Alphabetic.Alphabetic_Type(Info).Initialize(Info.Hidden);    
  24.      end Initialize;
  25.      
  26.      procedure Adjust(Info : in out Info_Type) is
  27.      begin
  28.      Alphabetic.Alphabetic_Type(Info).Adjust(Info.Hidden);
  29.      end Adjust;
  30.      
  31.      procedure Finalize(Info : in out Info_Type) is
  32.      begin
  33.      Alphabetic.Alphabetic_Type(Info).Finalize;
  34.      end Finalize;
  35.   end Info;
  36.  
  37.   package Human is
  38.      
  39.      type Attribut_Name_Type is (Full_Name,
  40.                   Logname,
  41.                   Password,
  42.                   Groups,
  43.                   Home,
  44.                   Interpreter,
  45.                   Phone_Number,
  46.                   Address,
  47.                   Language,
  48.                   Email);
  49.      
  50.      type Human_Type is tagged limited private;
  51.      
  52.      procedure Initialize(Human : out Human_Type);
  53.          
  54.   private
  55.      
  56.      use Info;
  57.      
  58.      type Info_Access is access all Info_Type'Class;                  
  59.            
  60.      type Attribut_Type is new Info_Type with
  61.      record
  62.         Name : Attribut_Name_Type;
  63.      end record;      
  64.      
  65.      type Full_Name_Type is new Attribut_type with
  66.      record
  67.         Full_name : Attribut_Type(True, False);
  68.      end record;
  69.  
  70.      
  71.      type Logname_Type is new Full_name_Type  with    
  72.      record
  73.         logname : Attribut_Type(True, False);
  74.      end record;
  75.      
  76.      type Authentifier_type is new Logname_Type with
  77.      record
  78.         Passwd : Attribut_Type(True, True);
  79.      end record;
  80.      
  81.      type Groups_type is new Authentifier_Type with
  82.      record
  83.         Groups : Attribut_Type(True, False);
  84.      end record;
  85.      
  86.      type User_Type is new groups_Type with
  87.      record
  88.         Home : Attribut_Type(True, False);
  89.      end record;
  90.      
  91.      type Interpreter_Type is new User_Type with
  92.      record
  93.         Interpreter : Attribut_Type(True, False);
  94.      end record;
  95.      
  96.      type Human_Type is tagged limited
  97.      record
  98.         Info : Info_Access;        
  99.      end record;
  100.   end Human;
  101.  
  102.  
  103.   package body Human is
  104.      procedure Initialize(Human : out Human_Type) is
  105.     
  106.      Constructor : Info_Access;
  107.     
  108.      begin        
  109.     
  110.      Text_Io.Put_line("Initialize constructor..." );    
  111.      Constructor := new Full_Name_Type(True, False);
  112.      -- ici je vais complèter l'objet au fur et a mesure.
  113.     
  114.      Human.info := Constructor;
  115.      end Initialize;
  116.   end Human;
  117.  
  118.   Jovalise : Human.Human_Type;
  119.  
  120.   use Human;
  121.  
  122. begin
  123.  
  124.   Jovalise.Initialize;
  125. end Main;


 
Mon problème pour le moment, c'est qu'a l'initialization du constructeur, j'obtiens deux lecture de type info_type parce que mon type Full_Logname_type est dérivé de type Attribut_type et contien une variable de type attribut type.
Je cherche l'implémentation qui va bien pour résoudre mon problème ?
Merci., merci encore, merci beaucoup.  :jap:

Reply

Marsh Posté le 23-01-2013 à 11:29:47    

Personne ?
 
Voici mes sources dans un paquet virtuel et l'erreur sous-jacente.
 

Code :
  1. with Ada.Finalization;
  2. package Virtual is
  3.   type Virtual_Type is abstract new Ada.Finalization.Controlled with null record;    
  4. end Virtual;
  5. with System.Storage_Elements;
  6. use System;
  7.  
  8. with Virtual;
  9. generic
  10.  
  11.   Max_Element : Storage_Elements.Storage_Count := 2;
  12.   type object_Type is new Virtual.Virtual_Type with private;
  13. package Objects is
  14.   type Object_Access is access all Object_Type'Class;
  15. end Objects;
  16.    
  17.    
  18. with Virtual;
  19. with Objects;
  20. with Ada.Unchecked_Deallocation;
  21. package Alphabetic is
  22.  
  23.   type Alphabetic_Type is abstract new Virtual.Virtual_type with private;
  24.  
  25.   procedure Initialize(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean);
  26.   procedure Adjust(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean);
  27.   procedure Finalize(Alphabetic : in out Alphabetic_Type'Class);
  28.      
  29. private  
  30.  
  31.   type String_Access is access all String;
  32.  
  33.   procedure Free is new Ada.Unchecked_Deallocation(String,
  34.                             String_Access);                            
  35.  
  36.   type String_Handle_Type Is new Virtual.Virtual_Type with
  37.      record
  38.      Value : String_Access;
  39.      end record;
  40.      
  41.   package Strings_Object is new Objects(2, String_Handle_Type);
  42.      
  43.   type Alphabetic_Type is abstract new Virtual.Virtual_type with
  44.      record
  45.      Object : Strings_Object.Object_Access;
  46.      end record;
  47. end Alphabetic;
  48. with Ada.Text_Io;
  49. use Ada;
  50.  
  51. package body Alphabetic is
  52.  
  53.  
  54.   function Get_Hidden return String is
  55.      Buffer, Line : String_Access := new String ' ("" );
  56.   begin
  57.      loop
  58.      loop
  59.         declare
  60.            Char : Character;
  61.         begin
  62.           
  63.            Text_Io.Get_Immediate(Char);
  64.            case Char is
  65.           when Character'Val(10) =>
  66.              Text_Io.New_Line;
  67.              return Line.all;
  68.           when Character'Val(127) =>
  69.              Buffer := new String ' (Line(Line'First..Line'Last-1));
  70.           when others =>
  71.              Buffer := new String ' (Line.all & Char);
  72.            end case;
  73.           
  74.            exit;
  75.         exception
  76.           
  77.            when Text_Io.End_Error =>
  78.           null;          
  79.         end;        
  80.      end loop;
  81.      Free(Line);
  82.      Line := new String ' (Buffer.all);
  83.      Free(Buffer);        
  84.      end loop;
  85.   end Get_Hidden;
  86.  
  87.  
  88.   function Get_Visible return String is
  89.      Buffer, Line : String_Access := new String ' ("" );
  90.   begin
  91.      loop
  92.      loop
  93.         declare
  94.            Char : Character;
  95.         begin          
  96.            Text_Io.Get_immediate(Char);
  97.            case Char is
  98.           when Character'Val(10) =>
  99.              Text_Io.New_Line;
  100.              return Line.all;
  101.           when Character'Val(127) =>
  102.              Buffer := new String ' (Line(Line'First..Line'Last-1));
  103.              Text_Io.Put(Character'Val(8) & ' ' & Character'Val(8));
  104.           when others =>
  105.              Buffer := new String ' (Line.all & Char);
  106.              Text_Io.Put(Char);
  107.            end case;
  108.           
  109.            exit;
  110.         exception
  111.           
  112.            when Text_Io.End_Error =>
  113.           null;          
  114.         end;        
  115.      end loop;
  116.      Free(Line);
  117.      Line := new String ' (Buffer.all);
  118.      Free(Buffer);        
  119.      end loop;
  120.   end Get_visible;
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.   procedure Initialize(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean) is
  128.   begin
  129.      if not Hidden then
  130.      Alphabetic.Object := new String_handle_Type ' (Virtual.Virtual_type with Value => new String ' (Get_visible));    
  131.      else
  132.      Alphabetic.Object := new String_handle_Type ' (Virtual.Virtual_type with Value => new String ' (Get_hidden));    
  133.      end if;
  134.   end Initialize;
  135.  
  136.   procedure Adjust(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean) is
  137.   begin
  138.      null;
  139.   end Adjust;
  140.  
  141.   procedure Finalize(Alphabetic : in out Alphabetic_Type'Class) is
  142.   begin
  143.      null;
  144.   end Finalize;
  145. end Alphabetic;


 
Le main à part :
 

Code :
  1. with Ada.Text_Io;
  2. use Ada;
  3. with Virtual;
  4. with Alphabetic;
  5. with Ada.Finalization;
  6. use Ada.Finalization;
  7. procedure Main is
  8.  
  9.   package Info is      
  10.      
  11.      type Info_Type(Auto   : Boolean;Hidden : Boolean) is new Alphabetic.Alphabetic_Type with null record;
  12.  
  13.      
  14.      procedure Initialize(Info : in out Info_Type);
  15.      procedure Adjust(Info : in out Info_Type);
  16.      procedure Finalize(Info : in out Info_Type);                  
  17.   end Info;
  18.  
  19.   package body Info is      
  20.      
  21.      Procedure Initialize(Info : in out Info_Type) is
  22.      begin
  23.      Alphabetic.Alphabetic_Type(Info).Initialize(Info.Hidden);    
  24.      end Initialize;
  25.      
  26.      procedure Adjust(Info : in out Info_Type) is
  27.      begin
  28.      Alphabetic.Alphabetic_Type(Info).Adjust(Info.Hidden);
  29.      end Adjust;
  30.      
  31.      procedure Finalize(Info : in out Info_Type) is
  32.      begin
  33.      Alphabetic.Alphabetic_Type(Info).Finalize;
  34.      end Finalize;
  35.   end Info;
  36.  
  37.   package Human is
  38.      
  39.      type Attribut_Name_Type is (Full_Name,
  40.                   Logname,
  41.                   Password,
  42.                   Groups,
  43.                   Home,
  44.                   Interpreter,
  45.                   Phone_Number,
  46.                   Address,
  47.                   Language,
  48.                   Email);
  49.      
  50.      
  51.      
  52.      type Human_Type is tagged limited private;
  53.      
  54.      procedure Initialize(Human : out Human_Type);
  55.      
  56.   private
  57.      
  58.      use Info;
  59.      
  60.      type Info_Access is access all Info_Type'Class;
  61.      
  62.      type Attribut_Type is new Info_Type with
  63.     null record;
  64.      
  65.      type Full_Name_Type is new attribut_Type with
  66.     null record;
  67.      
  68.      type Logname_Type is new Attribut_Type with
  69.      record
  70.         Full_Name : Info_Access;
  71.      end record;
  72.      
  73.      type Authentifier_type is new attribut_Type with
  74.      record
  75.         Logname : Info_Access;
  76.      end record;
  77.      
  78.      type Groups_type is new Attribut_Type with
  79.      record
  80.         Authentifier : Info_Access;
  81.      end record;
  82.      
  83.      
  84.      type Interpreter_Type is new attribut_Type with
  85.      record
  86.        Interpreter: Info_Access;
  87.      end record;
  88.      
  89.      type Identity_Type is new Interpreter_Type with
  90.      record
  91.         Phone_Number : Info_Access;
  92.         Address      : Info_Access;
  93.         Email        : Info_Access;
  94.      end record;
  95.      
  96.      type Identity_Access is access all Identity_Type'Class;
  97.      
  98.      type Human_Type is tagged limited
  99.      record
  100.         Info : info_Access;
  101.      end record;
  102.   end Human;
  103.  
  104.  
  105.   package body Human is
  106.      procedure Initialize(Human : out Human_Type) is
  107.          
  108.     
  109.      Constructor : Info_Access;
  110.      begin
  111.      Text_Io.Put_line("Create user: " );
  112.      Text_Io.Put("Full name: " );
  113.      Constructor := new Full_Name_Type(True, False);
  114.      Human.Info := new Logname_Type' ((True, False) with Full_Name => new Full_Name_Type ' (Constructor.all));
  115.     
  116.      end Initialize;
  117.   end Human;
  118.        
  119.   Jovalise : Human.Human_Type;
  120.  
  121.   use Human;
  122.  
  123. begin
  124.  
  125.   Jovalise.Initialize;
  126. end Main;


 
L'erreur, ça fais 4 heure que je tourne mon code dans tous les sens sans y arriver.

root@Muse:/home/root/Perfector# gnatmake main
gcc-4.4 -c main.adb
main.adb:114:43: no unique type for this aggregate
gnatmake: "main.adb" compilation error


 
 
Merci pour votre aide.

Reply

Marsh Posté le 23-01-2013 à 13:33:18    

J'ai réussi à quelque chose !  :o  
 
 

Code :
  1. with Ada.Text_Io;
  2. use Ada;
  3. with Virtual;
  4. with Alphabetic;
  5. with Ada.Finalization;
  6. use Ada.Finalization;
  7. procedure Main is
  8.  
  9.   package Info is      
  10.      
  11.      type Info_Type(Auto   : Boolean;Hidden : Boolean) is new Alphabetic.Alphabetic_Type with null record;
  12.  
  13.      
  14.      procedure Initialize(Info : in out Info_Type);
  15.      procedure Adjust(Info : in out Info_Type);
  16.      procedure Finalize(Info : in out Info_Type);                  
  17.   end Info;
  18.  
  19.   package body Info is      
  20.      
  21.      Procedure Initialize(Info : in out Info_Type) is
  22.      begin
  23.      Alphabetic.Alphabetic_Type(Info).Initialize(Info.Hidden);    
  24.      end Initialize;
  25.      
  26.      procedure Adjust(Info : in out Info_Type) is
  27.      begin
  28.      Alphabetic.Alphabetic_Type(Info).Adjust(Info.Hidden);
  29.      end Adjust;
  30.      
  31.      procedure Finalize(Info : in out Info_Type) is
  32.      begin
  33.      Alphabetic.Alphabetic_Type(Info).Finalize;
  34.      end Finalize;
  35.   end Info;
  36.  
  37.   package Human is
  38.      
  39.      type Attribut_Name_Type is (Full_Name,
  40.                   Logname,
  41.                   Password,
  42.                   Groups,
  43.                   Home,
  44.                   Interpreter,
  45.                   Phone_Number,
  46.                   Address,
  47.                   Language,
  48.                   Email);
  49.      
  50.      
  51.      
  52.      type Human_Type is tagged limited private;
  53.      
  54.      procedure Initialize(Human : out Human_Type);
  55.      
  56.   private
  57.      
  58.      use Info;
  59.      
  60.      type Info_Access is access all Info_Type'class;
  61.      
  62.      type Attribut_Type(Auto : Boolean;
  63.              Hidden : Boolean) is tagged
  64.      record
  65.         Info : Info_Type(Auto, Hidden);
  66.      end record;    
  67.  
  68.      type Attribut_Access is access all Attribut_Type'Class;
  69.      
  70.      
  71.      type Full_Name_Type is new Attribut_Type with
  72.     null record;
  73.      
  74.      type Logname_Type is new Full_Name_Type with
  75.     
  76.     null record;
  77.     
  78.      
  79.      type Authentifier_type is new Logname_type with
  80.     null record;
  81.      
  82.      type Human_Type is tagged limited
  83.      record
  84.         Attributs : Attribut_Access;
  85.      end record;
  86.   end Human;
  87.  
  88.  
  89.   package body Human is
  90.      procedure Initialize(Human : out Human_Type) is
  91.     
  92.     
  93.      Constructor : Info_Access;
  94.      begin
  95.      Text_Io.Put_line("Create user: " );
  96.      Text_Io.Put("Full name: " );
  97.      Human.Attributs := new Full_Name_Type(True, False);
  98.      Text_Io.Put("Log name: " );
  99.      Constructor := new Info_Type(True, False);
  100.      Human.attributs := new Logname_Type ' (logname_Type ' (True, False, Info_type(Constructor.all)));
  101.         Text_Io.Put("password: " );
  102.      Constructor := new Info_Type(True, True);
  103.         Human.attributs := new Authentifier_Type ' (Authentifier_type ' (True, True, Info_Type((constructor.all))));
  104.      
  105.      end Initialize;
  106.   end Human;
  107.  
  108.   Jovalise : Human.Human_Type;
  109.  
  110.   use Human;
  111.  
  112. begin
  113.  
  114.   Jovalise.Initialize;
  115. end Main;


 
 

root@Muse:/home/root/Perfector# gnatmake main
gcc-4.4 -c main.adb
gnatbind -x main.ali
gnatlink main.ali
root@Muse:/home/root/Perfector# ./main  
Create user:  
Full name: jovalise
Log name: jovalise
password:  
root@Muse:/home/root/Perfector#


 
 
Nana, nanère.


Message édité par Profil supprimé le 23-01-2013 à 13:35:01
Reply

Marsh Posté le 23-01-2013 à 17:03:50    

Je vais y arriver, je vais y arriver, etc.  :heink:  
 

Code :
  1. with Ada.Text_Io;
  2. use Ada;
  3.  
  4. package body Alphabetic is
  5.  
  6.   function Image(Alphabetic : in Alphabetic_Type'Class) return String is
  7.   begin
  8.      return Alphabetic.Object.Value.all;
  9.   end Image;
  10.  
  11.   procedure Print(Alphabetic : in Alphabetic_Type'Class) is
  12.   begin
  13.      Text_Io.Put( Alphabetic.Object.Value.all);
  14.   end print;
  15.  
  16.   function Get_Hidden return String is
  17.      Buffer, Line : String_Access := new String ' ("" );
  18.   begin
  19.      loop
  20.      loop
  21.         declare
  22.            Char : Character;
  23.         begin
  24.           
  25.            Text_Io.Get_Immediate(Char);
  26.            case Char is
  27.           when Character'Val(10) =>
  28.              Text_Io.New_Line;
  29.              return Line.all;
  30.           when Character'Val(127) =>
  31.              Buffer := new String ' (Line(Line'First..Line'Last-1));
  32.           when others =>
  33.              Buffer := new String ' (Line.all & Char);
  34.            end case;
  35.           
  36.            exit;
  37.         exception
  38.           
  39.            when Text_Io.End_Error =>
  40.           null;          
  41.         end;        
  42.      end loop;
  43.      Free(Line);
  44.      Line := new String ' (Buffer.all);
  45.      Free(Buffer);        
  46.      end loop;
  47.   end Get_Hidden;
  48.  
  49.  
  50.   function Get_Visible return String is
  51.      Buffer, Line : String_Access := new String ' ("" );
  52.   begin
  53.      loop
  54.      loop
  55.         declare
  56.            Char : Character;
  57.         begin          
  58.            Text_Io.Get_immediate(Char);
  59.            case Char is
  60.           when Character'Val(10) =>
  61.              Text_Io.New_Line;
  62.              return Line.all;
  63.           when Character'Val(127) =>
  64.              Buffer := new String ' (Line(Line'First..Line'Last-1));
  65.              Text_Io.Put(Character'Val(8) & ' ' & Character'Val(8));
  66.           when others =>
  67.              Buffer := new String ' (Line.all & Char);
  68.              Text_Io.Put(Char);
  69.            end case;
  70.           
  71.            exit;
  72.         exception
  73.           
  74.            when Text_Io.End_Error =>
  75.           null;          
  76.         end;        
  77.      end loop;
  78.      Free(Line);
  79.      Line := new String ' (Buffer.all);
  80.      Free(Buffer);        
  81.      end loop;
  82.   end Get_visible;
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.   procedure Initialize(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean) is
  90.   begin
  91.      if not Hidden then
  92.      Alphabetic.Object := new String_handle_Type ' (Virtual.Virtual_type with Value => new String ' (Get_visible));    
  93.      else
  94.      Alphabetic.Object := new String_handle_Type ' (Virtual.Virtual_type with Value => new String ' (Get_hidden));    
  95.      end if;
  96.   end Initialize;
  97.  
  98.   procedure Adjust(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean) is
  99.   begin
  100.      null;
  101.   end Adjust;
  102.  
  103.   procedure Finalize(Alphabetic : in out Alphabetic_Type'Class) is
  104.   begin
  105.      null;
  106.   end Finalize;
  107. end Alphabetic;
  108. with Virtual;
  109. with Objects;
  110. with Ada.Unchecked_Deallocation;
  111. package Alphabetic is
  112.  
  113.   type Alphabetic_Type is new Virtual.Virtual_type with private;
  114.  
  115.   procedure Initialize(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean);
  116.   procedure Adjust(Alphabetic : in out Alphabetic_Type'Class;Hidden : in Boolean);
  117.   procedure Finalize(Alphabetic : in out Alphabetic_Type'Class);
  118.   procedure print(Alphabetic : in Alphabetic_Type'Class);
  119.   function Image(Alphabetic : in Alphabetic_Type'Class) return String;
  120. private  
  121.  
  122.   type String_Access is access all String;
  123.  
  124.   procedure Free is new Ada.Unchecked_Deallocation(String,
  125.                             String_Access);                            
  126.  
  127.   type String_Handle_Type Is new Virtual.Virtual_Type with
  128.      record
  129.      Value : String_Access;
  130.      end record;
  131.      
  132.   package Strings_Object is new Objects(2, String_Handle_Type);
  133.      
  134.   type Alphabetic_Type is new Virtual.Virtual_type with
  135.      record
  136.      Object : Strings_Object.Object_Access;
  137.      end record;
  138. end Alphabetic;
  139. with Ada.Text_Io;
  140. use Ada;
  141. package body Full_Names is
  142.   procedure Initialize(Full_Name : in out Full_Name_Type) is
  143.   begin
  144.      Text_Io.Put("Full name: " );
  145.      Full_Name.name := new Info.Info_Type(True, False);
  146.   end Initialize;
  147.   procedure print(Full_Name : in Full_Name_Type'class) is
  148.   begin
  149.      Info.Print(Full_Name.Name.All);
  150.   end Print;
  151.   function Image(Full_Name : in Full_Name_Type'Class) return String is
  152.   begin
  153.      return Full_Name.Name.Image;
  154.   end Image;
  155.  
  156.  
  157. end Full_Names;
  158. with Ada.Finalization;
  159. with Info;
  160. package Full_Names is
  161.   type Full_Name_Type is new Ada.Finalization.Limited_Controlled with Private;
  162.   procedure Initialize(Full_Name : in out Full_Name_Type);
  163. private
  164.  
  165.   type Info_Access is access Info.Info_Type'Class;
  166.  
  167.   type Full_Name_Type is  new Ada.Finalization.Limited_Controlled with
  168.     record
  169.      Name : Info_Access;
  170.      end record;
  171.  
  172.   procedure print(Full_Name : in Full_Name_Type'class);
  173.   function Image(Full_Name : in Full_Name_Type'Class) return String;
  174. end Full_Names;
  175. with Ada.Text_Io;
  176. use Ada;
  177. package body Humans is
  178.   procedure Initialize(Human : in out Human_Type'Class) is
  179.   begin
  180.      Human.password.Initialize;
  181.   end Initialize;
  182.  
  183.   procedure Print(Human : in Human_Type'Class) is
  184.   begin
  185.      Human.password.Print;
  186.   end Print;
  187. end Humans;
  188. with Ada.Finalization;
  189. --with Full_Names;
  190. --with Lognames;
  191. with Passwords;
  192. package Humans is
  193.  
  194.   type Attribut_Name_Type is (Full_Name,
  195.                    Logname,
  196.                    Password,
  197.                    Groups,
  198.                    Home,
  199.                    Interpreter,
  200.                    Phone_Number,
  201.                    Address,
  202.                    Language,
  203.                    Email);
  204.  
  205.  
  206.  
  207.   type Human_Type is new Ada.Finalization.Limited_Controlled with private;
  208.  
  209.   procedure Print(Human : in Human_Type'Class);
  210.   procedure Initialize(Human : in out Human_Type'Class);
  211. private
  212.  
  213.  
  214.  
  215.   type Human_Type is new Ada.Finalization.Limited_Controlled with
  216.      record    
  217.      password :  Passwords.Password_Type;
  218.      --Full_Name :  Full_Names.Full_Name_Type;    
  219.      end record;
  220.  
  221.  
  222. end Humans;
  223.  
  224. package body Info is      
  225.  
  226.   function Image(Info : in Info_Type'Class) return String is
  227.   begin
  228.      return Alphabetic.Image(Info);      
  229.   end Image;
  230.  
  231.  
  232.   procedure Print(Info : in Info_Type'Class) is
  233.  
  234.   begin
  235.      if not Info.Hidden then
  236.      Alphabetic.Print(Info);
  237.      end if;
  238.   end Print;
  239.  
  240.   procedure Initialize(Info : in out Info_Type) is
  241.   begin
  242.      Alphabetic.Alphabetic_Type(Info).Initialize(Info.Hidden);    
  243.   end Initialize;
  244.      
  245.   procedure Adjust(Info : in out Info_Type) is
  246.   begin
  247.      Alphabetic.Alphabetic_Type(Info).Adjust(Info.Hidden);
  248.   end Adjust;
  249.  
  250.   procedure Finalize(Info : in out Info_Type) is
  251.   begin
  252.      Alphabetic.Alphabetic_Type(Info).Finalize;
  253.   end Finalize;
  254. end Info;
  255. with Virtual;
  256. with Alphabetic;
  257. package Info is      
  258.      
  259.   type Info_Type(Auto   : Boolean;Hidden : Boolean) is tagged private;
  260.   procedure Print(Info : in Info_Type'Class);
  261.   function Image(Info : in Info_Type'Class) return String;
  262. private
  263.   type Info_Type(Auto   : Boolean;Hidden : Boolean) is new Alphabetic.Alphabetic_Type with null record;
  264.   procedure Initialize(Info : in out Info_Type);
  265.   procedure Adjust(Info : in out Info_Type);
  266.   procedure Finalize(Info : in out Info_Type);                  
  267. end Info;
  268. with Ada.Text_Io;
  269. use Ada;
  270. package body Lognames is
  271.   procedure Initialize(Logname : in out Logname_Type) is
  272.   begin      
  273.      if Logname.Full_Name.Image = "" then
  274.      raise Program_Error;
  275.      end if;
  276.      Text_Io.Put("Logname: " );
  277.      Logname.logname := new Info.Info_Type(True, False);
  278.   end Initialize;
  279.   procedure print(Logname : in Logname_Type'class) is
  280.   begin
  281.      Logname.Full_Name.Print;
  282.      Info.Print(Logname.Logname.All);
  283.   end Print;
  284.   function Image(Logname : in Logname_Type'Class) return String is
  285.   begin
  286.      return Logname.Logname.Image;
  287.   end Image;
  288.  
  289.  
  290. end Lognames;
  291. with Full_Names;
  292. with Ada.Finalization;
  293. with Info;
  294. package Lognames is
  295.   type Logname_Type is new Ada.Finalization.Limited_Controlled with private;          
  296.   procedure Initialize(Logname : in out Logname_Type);
  297. private
  298.  
  299.   type Info_Access is access Info.Info_Type'Class;
  300.  
  301.   type Logname_Type is  new Ada.Finalization.Limited_Controlled with
  302.     record
  303.     Logname : Info_Access;
  304.     Full_Name : Full_names.Full_Name_Type;
  305.      end record;
  306.  
  307.   procedure print(Logname : in Logname_Type'class);
  308.   function Image(Logname : in Logname_Type'Class) return String;
  309. end lognames;
  310. with System.Storage_Elements;
  311. use System;
  312.  
  313. with Virtual;
  314. generic
  315.  
  316.   Max_Element : Storage_Elements.Storage_Count := 2;
  317.   type object_Type is new Virtual.Virtual_Type with private;
  318. package Objects is
  319.   type Object_Access is access all Object_Type'Class;
  320. end Objects;
  321.    
  322.    
  323. with Ada.Text_Io;
  324. use Ada;
  325. package body Passwords is
  326.   procedure Initialize(Password : in out Password_Type) is
  327.   begin      
  328.      if Password.Logname.Image = "" then
  329.      raise Program_Error;
  330.      end if;
  331.      Text_Io.Put("Password: " );
  332.      Password.Password := new Info.Info_Type(True, True);
  333.   end Initialize;
  334.   procedure print(Password : in Password_Type'class) is
  335.   begin      
  336.      Password.Logname.Print;
  337.      Info.Print(Password.Password.All);
  338.   end Print;
  339.   function Image(Password : in Password_Type'Class) return String is
  340.   begin
  341.      return Password.Password.Image;
  342.   end Image;
  343.  
  344.  
  345. end Passwords;
  346. with Lognames;
  347. with Ada.Finalization;
  348. with Info;
  349. package Passwords is
  350.   type Password_Type is new Ada.Finalization.Limited_Controlled with private;          
  351.   procedure Initialize(Password : in out Password_Type);
  352. private
  353.  
  354.   type Info_Access is access Info.Info_Type'Class;
  355.  
  356.   type Password_Type is  new Ada.Finalization.Limited_Controlled with
  357.     record
  358.     Password : Info_Access;
  359.     Logname  : Lognames.Logname_Type;
  360.      end record;
  361.  
  362.   procedure print(Password : in Password_Type'class);
  363.   function Image(Password : in Password_Type'Class) return String;
  364. end passwords;
  365. with Ada.Finalization;
  366. package Virtual is
  367.   type Virtual_Type is abstract new Ada.Finalization.Controlled with null record;    
  368. end Virtual;


 
Résultat :

root@Muse:/home/root/Humanity-Perfect# emacs
root@Muse:/home/root/Humanity-Perfect# gnatmake src/main.adb -aIsrc/lib/
gcc-4.4 -c -Isrc/ -Isrc/lib/ -I- src/main.adb
gnatbind -aIsrc/lib/ -x main.ali
gnatlink main.ali
root@Muse:/home/root/Humanity-Perfect# ./main  
Initialize identity:  
Full name: Manuel
Logname: jovalise
Password:  
Identity setting:  
Manueljovalise
root@Muse:/home/root/Humanity-Perfect# ./main  
Initialize identity:  
Full name:  
 
raised PROGRAM_ERROR : lognames.adb:7 explicit raise
root@Muse:/home/root/Humanity-Perfect# ./main  
Initialize identity:  
Full name: Manuel
Logname:  
 
raised PROGRAM_ERROR : passwords.adb:7 explicit raise
root@Muse:/home/root/Humanity-Perfect# ./main  
Initialize identity:  
Full name: Manuel
Logname: jovalise
Password:  
Identity setting:  
Manueljovalise
root@Muse:/home/root/Humanity-Perfect#  


 
 
Tout ceci est tout à fait normal, je teste pas le password, j'ai pourtant entré une chaîne vide, mais donc, j'ai pas vérifié.


Message édité par Profil supprimé le 23-01-2013 à 17:07:38
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed