[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