home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_intr.adb < prev    next >
Text File  |  1996-09-28  |  8KB  |  234 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             S E M _ I N T R                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.8 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. --  Processing for intrinsic subprogram declarations
  26.  
  27. with Atree;    use Atree;
  28. with Einfo;    use Einfo;
  29. with Errout;   use Errout;
  30. with Namet;    use Namet;
  31. with Sem_Ch13; use Sem_Ch13;
  32. with Sem_Util; use Sem_Util;
  33. with Sinfo;    use Sinfo;
  34. with Snames;   use Snames;
  35. with Stand;    use Stand;
  36. with Uintp;    use Uintp;
  37.  
  38. package body Sem_Intr is
  39.  
  40.    -----------------------
  41.    -- Local Subprograms --
  42.    -----------------------
  43.  
  44.    procedure Check_Divide (E : Entity_Id; N : Node_Id);
  45.    --  Check intrinsic Divide subprogram. There must be four arguments,
  46.    --  and all four arguments must be decimal types. The first two
  47.    --  arguments must be mode IN, and the last two must be mode OUT.
  48.  
  49.    procedure Check_Shift (E : Entity_Id; N : Node_Id);
  50.    --  Check intrinsic shift subprogram, the two arguments are the same
  51.    --  as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
  52.    --  declaration, and the node for the pragma argument, used for messages)
  53.  
  54.    procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
  55.    --  Post error message for bad intrinsic, the message itself is posted
  56.    --  on the appropriate spec node and another message is placed on the
  57.    --  pragma itself, referring to the spec. S is the node in the spec on
  58.    --  which the message is to be placed, and N is the pragma argument node.
  59.  
  60.    ------------------
  61.    -- Check_Divide --
  62.    ------------------
  63.  
  64.    procedure Check_Divide (E : Entity_Id; N : Node_Id) is
  65.       Arg   : Node_Id;
  66.       Nargs : Nat;
  67.  
  68.    begin
  69.       if Ekind (E) /= E_Procedure
  70.         and then Ekind (E) /= E_Generic_Procedure
  71.       then
  72.          Errint ("intrinsic divide subprogram must be procedure", E, N);
  73.          return;
  74.       end if;
  75.  
  76.       Arg := First_Formal (E);
  77.       Nargs := 0;
  78.       while Present (Arg) loop
  79.          Nargs := Nargs + 1;
  80.  
  81.          if not Is_Decimal_Fixed_Point_Type (Etype (Arg)) then
  82.             Errint ("intrinsic divide argument must be decimal type", Arg, N);
  83.             return;
  84.          end if;
  85.  
  86.          if (Nargs <= 2 and then Ekind (Arg) /= E_In_Parameter)
  87.            or else (Nargs > 2 and then Ekind (Arg) /= E_Out_Parameter)
  88.          then
  89.             Errint ("intrinsic divide argument has wrong mode", Arg, N);
  90.          end if;
  91.  
  92.          Arg := Next_Formal (Arg);
  93.       end loop;
  94.  
  95.       if Nargs /= 4 then
  96.          Errint ("wrong number of arguments for intrinsic divide", E, N);
  97.       end if;
  98.  
  99.       --  All tests have passed, divide procedure can be marked intrinsic
  100.  
  101.       Set_Is_Intrinsic_Subprogram (E);
  102.    end Check_Divide;
  103.  
  104.    --------------------------------
  105.    -- Check_Intrinsic_Subprogram --
  106.    --------------------------------
  107.  
  108.    procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
  109.       Spec : constant Node_Id := Specification (Get_Declaration_Node (E));
  110.       Nam  : Name_Id;
  111.  
  112.    begin
  113.       if Present (Spec)
  114.         and then Present (Generic_Parent (Spec))
  115.       then
  116.          Nam := Chars (Generic_Parent (Spec));
  117.       else
  118.          Nam := Chars (E);
  119.       end if;
  120.  
  121.       --  Simply ignore cases where name is an operator name
  122.  
  123.       Get_Name_String (Nam);
  124.  
  125.       if Name_Buffer (1) = 'O' then
  126.          return;
  127.  
  128.       --  Shift cases
  129.  
  130.       elsif Nam = Name_Rotate_Left
  131.         or else Nam = Name_Rotate_Right
  132.         or else Nam = Name_Shift_Left
  133.         or else Nam = Name_Shift_Right
  134.         or else Nam = Name_Shift_Right_Arithmetic
  135.       then
  136.          Check_Shift (E, N);
  137.  
  138.       --  Unchecked conversion and deallocation, no further processing needed
  139.  
  140.       elsif Nam = Name_Unchecked_Conversion
  141.         and then Ekind (E) = E_Generic_Function
  142.       then
  143.          null;
  144.  
  145.       elsif Nam = Name_Unchecked_Deallocation then
  146.          null;
  147.  
  148.       --  Case of Divide routine in package Decimal
  149.  
  150.       elsif Nam = Name_Divide then
  151.          Check_Divide (E, N);
  152.  
  153.       --  For now, no other intrinsic subprograms are recognized
  154.  
  155.       else
  156.          Errint ("unrecognized intrinsic subprogram", E, N);
  157.       end if;
  158.    end Check_Intrinsic_Subprogram;
  159.  
  160.    -----------------
  161.    -- Check_Shift --
  162.    -----------------
  163.  
  164.    procedure Check_Shift (E : Entity_Id; N : Node_Id) is
  165.       Arg1 : Node_Id;
  166.       Arg2 : Node_Id;
  167.       Size : Nat;
  168.  
  169.    begin
  170.       if Ekind (E) /= E_Function
  171.         and then Ekind (E) /= E_Generic_Function
  172.       then
  173.          Errint ("intrinsic shift subprogram must be a function", E, N);
  174.          return;
  175.       end if;
  176.  
  177.       Arg1 := First_Formal (E);
  178.  
  179.       if Present (Arg1) then
  180.          Arg2 := Next_Formal (Arg1);
  181.       else
  182.          Arg2 := Empty;
  183.       end if;
  184.  
  185.       if Arg1 = Empty or else Arg2 = Empty then
  186.          Errint ("intrinsic shift function must have two arguments", E, N);
  187.          return;
  188.       end if;
  189.  
  190.       if not Is_Integer_Type (Etype (Arg1)) then
  191.          Errint ("first argument to shift must be integer type", Arg1, N);
  192.          return;
  193.       end if;
  194.  
  195.       if Etype (Arg2) /= Standard_Natural then
  196.          Errint ("second argument to shift must be type Natural", Arg2, N);
  197.          return;
  198.       end if;
  199.  
  200.       Size := UI_To_Int (Esize (Etype (Arg1)));
  201.  
  202.       if Size /= 8
  203.         and then Size /= 16
  204.         and then Size /= 32
  205.         and then Size /= 64
  206.       then
  207.          Errint
  208.            ("first argument for shift must have size 8, 16, 32 or 64",
  209.              Parameter_Type (Arg1), N);
  210.          return;
  211.  
  212.       elsif Etype (Arg1) /= Etype (E) then
  213.          Errint
  214.            ("return type of shift must match first argument", E, N);
  215.          return;
  216.       end if;
  217.  
  218.       --  All tests have passed, shift function can be marked intrinsic
  219.  
  220.       Set_Is_Intrinsic_Subprogram (E);
  221.    end Check_Shift;
  222.  
  223.    ------------
  224.    -- Errint --
  225.    ------------
  226.  
  227.    procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
  228.    begin
  229.       Error_Msg_N (Msg, S);
  230.       Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
  231.    end Errint;
  232.  
  233. end Sem_Intr;
  234.