1. -- 
  2. -- Copyright (c) 2012 Kevin Wellwood 
  3. -- All rights reserved. 
  4. -- 
  5. -- This source code is distributed under the Modified BSD License. For terms and 
  6. -- conditions, see license.txt. 
  7. -- 
  8.  
  9. with Allegro_Ids;                       use Allegro_Ids; 
  10. with Interfaces;                        use Interfaces; 
  11. with System;                            use System; 
  12.  
  13. -- Allegro 4.4.2 - System routines 
  14. package Allegro is 
  15.     pragma Elaborate_Body; 
  16.  
  17.     type A_Close_Button_Procedure is 
  18.         access procedure; 
  19.  
  20.     type A_Integer is access all Integer; 
  21.  
  22.     type    CPU_Family_Type is private; 
  23.     type    CPU_Model_Type is private; 
  24.     subtype CPU_Capabilities_Type is Unsigned_32; 
  25.  
  26.     type OS_Type_Type is private; 
  27.  
  28.     --------------------------------------------------------------------------- 
  29.  
  30.     CPU_ID       : constant CPU_Capabilities_Type; 
  31.     CPU_FPU      : constant CPU_Capabilities_Type; 
  32.     CPU_MMX      : constant CPU_Capabilities_Type; 
  33.     CPU_MMXPLUS  : constant CPU_Capabilities_Type; 
  34.     CPU_SSE      : constant CPU_Capabilities_Type; 
  35.     CPU_SSE2     : constant CPU_Capabilities_Type; 
  36.     CPU_3DNOW    : constant CPU_Capabilities_Type; 
  37.     CPU_ENH3DNOW : constant CPU_Capabilities_Type; 
  38.     CPU_CMOV     : constant CPU_Capabilities_Type; 
  39.     CPU_AMD64    : constant CPU_Capabilities_Type; 
  40.     CPU_IA64     : constant CPU_Capabilities_Type; 
  41.     CPU_SSE3     : constant CPU_Capabilities_Type; 
  42.  
  43.     CPU_FAMILY_UNKNOWN  : constant CPU_Family_Type; 
  44.     CPU_FAMILY_I386     : constant CPU_Family_Type; 
  45.     CPU_FAMILY_I486     : constant CPU_Family_Type; 
  46.     CPU_FAMILY_I586     : constant CPU_Family_Type; 
  47.     CPU_FAMILY_I686     : constant CPU_Family_Type; 
  48.     CPU_FAMILY_ITANIUM  : constant CPU_Family_Type; 
  49.     CPU_FAMILY_EXTENDED : constant CPU_Family_Type; 
  50.  
  51.     -- CPU models - PC 
  52.     -- 486 
  53.     CPU_MODEL_I486DX              : constant CPU_Model_Type; 
  54.     CPU_MODEL_I486DX50            : constant CPU_Model_Type; 
  55.     CPU_MODEL_I486SX              : constant CPU_Model_Type; 
  56.     CPU_MODEL_I487SX              : constant CPU_Model_Type; 
  57.     CPU_MODEL_I486SL              : constant CPU_Model_Type; 
  58.     CPU_MODEL_I486SX2             : constant CPU_Model_Type; 
  59.     CPU_MODEL_I486DX2             : constant CPU_Model_Type; 
  60.     CPU_MODEL_I486DX4             : constant CPU_Model_Type; 
  61.  
  62.     -- Intel/586 
  63.     CPU_MODEL_PENTIUM             : constant CPU_Model_Type; 
  64.     CPU_MODEL_PENTIUMP54C         : constant CPU_Model_Type; 
  65.     CPU_MODEL_PENTIUMOVERDRIVE    : constant CPU_Model_Type; 
  66.     CPU_MODEL_PENTIUMOVERDRIVEDX4 : constant CPU_Model_Type; 
  67.     CPU_MODEL_CYRIX               : constant CPU_Model_Type; 
  68.     CPU_MODEL_UNKNOWN             : constant CPU_Model_Type; 
  69.  
  70.     -- AMD/586 
  71.     CPU_MODEL_K5                  : constant CPU_Model_Type; 
  72.     CPU_MODEL_K6                  : constant CPU_Model_Type; 
  73.  
  74.     -- Intel/686 
  75.     CPU_MODEL_PENTIUMPROA          : constant CPU_Model_Type; 
  76.     CPU_MODEL_PENTIUMPRO           : constant CPU_Model_Type; 
  77.     CPU_MODEL_PENTIUMIIKLAMATH     : constant CPU_Model_Type; 
  78.     CPU_MODEL_PENTIUMII            : constant CPU_Model_Type; 
  79.     CPU_MODEL_CELERON              : constant CPU_Model_Type; 
  80.     CPU_MODEL_PENTIUMIIIKATMAI     : constant CPU_Model_Type; 
  81.     CPU_MODEL_PENTIUMIIICOPPERMINE : constant CPU_Model_Type; 
  82.     CPU_MODEL_PENTIUMIIIMOBILE     : constant CPU_Model_Type; 
  83.  
  84.     -- AMD/686 
  85.     CPU_MODEL_ATHLON               : constant CPU_Model_Type; 
  86.     CPU_MODEL_DURON                : constant CPU_Model_Type; 
  87.  
  88.     -- Information when CPU_Family is CPU_FAMILY_EXTENDED 
  89.     CPU_MODEL_PENTIUMIV            : constant CPU_Model_Type; 
  90.     CPU_MODEL_XEON                 : constant CPU_Model_Type; 
  91.     CPU_MODEL_ATHLON64             : constant CPU_Model_Type; 
  92.     CPU_MODEL_OPTERON              : constant CPU_Model_Type; 
  93.  
  94.     OSTYPE_UNKNOWN  : constant OS_Type_Type; 
  95.     OSTYPE_WIN3     : constant OS_Type_Type; 
  96.     OSTYPE_WIN95    : constant OS_Type_Type; 
  97.     OSTYPE_WIN98    : constant OS_Type_Type; 
  98.     OSTYPE_WINME    : constant OS_Type_Type; 
  99.     OSTYPE_WINNT    : constant OS_Type_Type; 
  100.     OSTYPE_WIN2000  : constant OS_Type_Type; 
  101.     OSTYPE_WINXP    : constant OS_Type_Type; 
  102.     OSTYPE_WIN2003  : constant OS_Type_Type; 
  103.     OSTYPE_WINVISTA : constant OS_Type_Type; 
  104.     OSTYPE_WIN7     : constant OS_Type_Type; 
  105.     OSTYPE_OS2      : constant OS_Type_Type; 
  106.     OSTYPE_WARP     : constant OS_Type_Type; 
  107.     OSTYPE_DOSEMU   : constant OS_Type_Type; 
  108.     OSTYPE_OPENDOS  : constant OS_Type_Type; 
  109.     OSTYPE_LINUX    : constant OS_Type_Type; 
  110.     OSTYPE_SUNOS    : constant OS_Type_Type; 
  111.     OSTYPE_FREEBSD  : constant OS_Type_Type; 
  112.     OSTYPE_NETBSD   : constant OS_Type_Type; 
  113.     OSTYPE_OPENBSD  : constant OS_Type_Type; 
  114.     OSTYPE_IRIX     : constant OS_Type_Type; 
  115.     OSTYPE_DARWIN   : constant OS_Type_Type; 
  116.     OSTYPE_QNX      : constant OS_Type_Type; 
  117.     OSTYPE_UNIX     : constant OS_Type_Type; 
  118.     OSTYPE_BEOS     : constant OS_Type_Type; 
  119.     OSTYPE_MACOS    : constant OS_Type_Type; 
  120.     OSTYPE_MACOSX   : constant OS_Type_Type; 
  121.  
  122.     ---------------------------------------------------------------------------- 
  123.  
  124.     procedure Allegro_Date( day, month, year : out Positive ); 
  125.  
  126.     procedure Allegro_Exit; 
  127.  
  128.     function Allegro_Error return String; 
  129.  
  130.     function Allegro_Id return String; 
  131.  
  132.     -- Binding only: Returns a copyright tag for Allegro. 
  133.     function Allegro_Copyright return String; 
  134.  
  135.     function Allegro_Initialize return Integer; 
  136.  
  137.     -- Initializes Allegro with SYSTEM_NONE for command line applications 
  138.     function Allegro_Initialize_Cmdline return Integer; 
  139.  
  140.     procedure Allegro_Message( message : String ); 
  141.  
  142.     procedure Allegro_Version( major, minor, wip : out Integer ); 
  143.  
  144.     procedure Check_CPU; 
  145.  
  146.     function CPU_Capabilities return CPU_Capabilities_Type; 
  147.     function CPU_Family return CPU_Family_Type; 
  148.     function CPU_Model return CPU_Model_Type; 
  149.     function CPU_Vendor return String; 
  150.  
  151.     function Desktop_Color_Depth return Natural; 
  152.  
  153.     procedure Desktop_Resolution( width, 
  154.                                   height  : out Natural; 
  155.                                   success : out Boolean ); 
  156.  
  157.     function Install_Allegro( system_id  : Integer; 
  158.                               errno_ptr  : Address; 
  159.                               atexit_ptr : Address ) return Integer; 
  160.  
  161.     function Is_OS_Multitasking return Boolean; 
  162.  
  163.     function OS_Type return OS_Type_Type; 
  164.     function OS_Version return Integer; 
  165.     function OS_Revision return Integer; 
  166.  
  167.     function Set_Close_Button_Callback( handle : A_Close_Button_Procedure ) return Integer; 
  168.  
  169.     procedure Set_Window_Title( name : String ); 
  170.  
  171.     function To_String( capabilities : CPU_Capabilities_Type ) return String; 
  172.  
  173.     function To_String( family : CPU_Family_Type ) return String; 
  174.  
  175.     function To_String( family : CPU_Family_Type; 
  176.                         model  : CPU_Model_Type ) return String; 
  177.  
  178.     function To_String( os : OS_Type_Type ) return String; 
  179.  
  180.     ---------------------------------------------------------------------------- 
  181.  
  182.     type Ada_Main_Procedure is access procedure; 
  183.  
  184.     -- Sets the main Ada procedure for the application at elaboration time. 
  185.     -- If it has already been set, a Program_Error exception will be raised. 
  186.     procedure Set_Ada_Main( main : Ada_Main_Procedure ); 
  187.  
  188. private 
  189.  
  190.     type CPU_Family_Type is new Unsigned_32; 
  191.  
  192.     type CPU_Model_Type is new Unsigned_32; 
  193.  
  194.     type OS_Type_Type is new AL_ID; 
  195.  
  196.     ---------------------------------------------------------------------------- 
  197.  
  198.     CPU_ID       : constant CPU_Capabilities_Type := 16#0001#; 
  199.     CPU_FPU      : constant CPU_Capabilities_Type := 16#0002#; 
  200.     CPU_MMX      : constant CPU_Capabilities_Type := 16#0004#; 
  201.     CPU_MMXPLUS  : constant CPU_Capabilities_Type := 16#0008#; 
  202.     CPU_SSE      : constant CPU_Capabilities_Type := 16#0010#; 
  203.     CPU_SSE2     : constant CPU_Capabilities_Type := 16#0020#; 
  204.     CPU_3DNOW    : constant CPU_Capabilities_Type := 16#0040#; 
  205.     CPU_ENH3DNOW : constant CPU_Capabilities_Type := 16#0080#; 
  206.     CPU_CMOV     : constant CPU_Capabilities_Type := 16#0100#; 
  207.     CPU_AMD64    : constant CPU_Capabilities_Type := 16#0200#; 
  208.     CPU_IA64     : constant CPU_Capabilities_Type := 16#0400#; 
  209.     CPU_SSE3     : constant CPU_Capabilities_Type := 16#0800#; 
  210.  
  211.     CPU_FAMILY_UNKNOWN  : constant CPU_Family_Type :=  0; 
  212.     CPU_FAMILY_I386     : constant CPU_Family_Type :=  3; 
  213.     CPU_FAMILY_I486     : constant CPU_Family_Type :=  4; 
  214.     CPU_FAMILY_I586     : constant CPU_Family_Type :=  5; 
  215.     CPU_FAMILY_I686     : constant CPU_Family_Type :=  6; 
  216.     CPU_FAMILY_ITANIUM  : constant CPU_Family_Type :=  7; 
  217.     CPU_FAMILY_EXTENDED : constant CPU_Family_Type := 15; 
  218.  
  219.     CPU_MODEL_I486DX               : constant CPU_Model_Type := 0; 
  220.     CPU_MODEL_I486DX50             : constant CPU_Model_Type := 1; 
  221.     CPU_MODEL_I486SX               : constant CPU_Model_Type := 2; 
  222.     CPU_MODEL_I487SX               : constant CPU_Model_Type := 3; 
  223.     CPU_MODEL_I486SL               : constant CPU_Model_Type := 4; 
  224.     CPU_MODEL_I486SX2              : constant CPU_Model_Type := 5; 
  225.     CPU_MODEL_I486DX2              : constant CPU_Model_Type := 7; 
  226.     CPU_MODEL_I486DX4              : constant CPU_Model_Type := 8; 
  227.  
  228.     CPU_MODEL_PENTIUM              : constant CPU_Model_Type :=  1; 
  229.     CPU_MODEL_PENTIUMP54C          : constant CPU_Model_Type :=  2; 
  230.     CPU_MODEL_PENTIUMOVERDRIVE     : constant CPU_Model_Type :=  3; 
  231.     CPU_MODEL_PENTIUMOVERDRIVEDX4  : constant CPU_Model_Type :=  4; 
  232.     CPU_MODEL_CYRIX                : constant CPU_Model_Type := 14; 
  233.     CPU_MODEL_UNKNOWN              : constant CPU_Model_Type := 15; 
  234.  
  235.     CPU_MODEL_K5                   : constant CPU_Model_Type := 0; 
  236.     CPU_MODEL_K6                   : constant CPU_Model_Type := 6; 
  237.  
  238.     CPU_MODEL_PENTIUMPROA          : constant CPU_Model_Type := 0; 
  239.     CPU_MODEL_PENTIUMPRO           : constant CPU_Model_Type := 1; 
  240.     CPU_MODEL_PENTIUMIIKLAMATH     : constant CPU_Model_Type := 3; 
  241.     CPU_MODEL_PENTIUMII            : constant CPU_Model_Type := 5; 
  242.     CPU_MODEL_CELERON              : constant CPU_Model_Type := 6; 
  243.     CPU_MODEL_PENTIUMIIIKATMAI     : constant CPU_Model_Type := 7; 
  244.     CPU_MODEL_PENTIUMIIICOPPERMINE : constant CPU_Model_Type := 8; 
  245.     CPU_MODEL_PENTIUMIIIMOBILE     : constant CPU_Model_Type := 9; 
  246.  
  247.     CPU_MODEL_ATHLON               : constant CPU_Model_Type := 2; 
  248.     CPU_MODEL_DURON                : constant CPU_Model_Type := 3; 
  249.  
  250.     CPU_MODEL_PENTIUMIV            : constant CPU_Model_Type := 0; 
  251.     CPU_MODEL_XEON                 : constant CPU_Model_Type := 2; 
  252.     CPU_MODEL_ATHLON64             : constant CPU_Model_Type := 4; 
  253.     CPU_MODEL_OPTERON              : constant CPU_Model_Type := 5; 
  254.  
  255.     OSTYPE_UNKNOWN  : constant OS_Type_Type := OS_Type_Type(AL_ID_NONE); 
  256.     OSTYPE_WIN3     : constant OS_Type_Type := To_AL_ID('W','I','N','3'); 
  257.     OSTYPE_WIN95    : constant OS_Type_Type := To_AL_ID('W','9','5',' '); 
  258.     OSTYPE_WIN98    : constant OS_Type_Type := To_AL_ID('W','9','8',' '); 
  259.     OSTYPE_WINME    : constant OS_Type_Type := To_AL_ID('W','M','E',' '); 
  260.     OSTYPE_WINNT    : constant OS_Type_Type := To_AL_ID('W','N','T',' '); 
  261.     OSTYPE_WIN2000  : constant OS_Type_Type := To_AL_ID('W','2','K',' '); 
  262.     OSTYPE_WINXP    : constant OS_Type_Type := To_AL_ID('W','X','P',' '); 
  263.     OSTYPE_WIN2003  : constant OS_Type_Type := To_AL_ID('W','2','K','3'); 
  264.     OSTYPE_WINVISTA : constant OS_Type_Type := To_AL_ID('W','V','S','T'); 
  265.     OSTYPE_WIN7     : constant OS_Type_Type := To_AL_ID('W','I','N','7'); 
  266.     OSTYPE_OS2      : constant OS_Type_Type := To_AL_ID('O','S','2',' '); 
  267.     OSTYPE_WARP     : constant OS_Type_Type := To_AL_ID('W','A','R','P'); 
  268.     OSTYPE_DOSEMU   : constant OS_Type_Type := To_AL_ID('D','E','M','U'); 
  269.     OSTYPE_OPENDOS  : constant OS_Type_Type := To_AL_ID('O','D','O','S'); 
  270.     OSTYPE_LINUX    : constant OS_Type_Type := To_AL_ID('T','U','X',' '); 
  271.     OSTYPE_SUNOS    : constant OS_Type_Type := To_AL_ID('S','U','N',' '); 
  272.     OSTYPE_FREEBSD  : constant OS_Type_Type := To_AL_ID('F','B','S','D'); 
  273.     OSTYPE_NETBSD   : constant OS_Type_Type := To_AL_ID('N','B','S','D'); 
  274.     OSTYPE_OPENBSD  : constant OS_Type_Type := To_AL_ID('O','B','S','D'); 
  275.     OSTYPE_IRIX     : constant OS_Type_Type := To_AL_ID('I','R','I','X'); 
  276.     OSTYPE_DARWIN   : constant OS_Type_Type := To_AL_ID('D','A','R','W'); 
  277.     OSTYPE_QNX      : constant OS_Type_Type := To_AL_ID('Q','N','X',' '); 
  278.     OSTYPE_UNIX     : constant OS_Type_Type := To_AL_ID('U','N','I','X'); 
  279.     OSTYPE_BEOS     : constant OS_Type_Type := To_AL_ID('B','E','O','S'); 
  280.     OSTYPE_MACOS    : constant OS_Type_Type := To_AL_ID('M','A','C',' '); 
  281.     OSTYPE_MACOSX   : constant OS_Type_Type := To_AL_ID('M','A','C','X'); 
  282.  
  283.     ---------------------------------------------------------------------------- 
  284.  
  285.     ada_main : Ada_Main_Procedure; 
  286.  
  287.     ---------------------------------------------------------------------------- 
  288.  
  289.     pragma Convention( C, A_Close_Button_Procedure ); 
  290.  
  291.     pragma Import( C, Allegro_Initialize, "allegro_initialize" ); 
  292.     pragma Import( C, Allegro_Initialize_Cmdline, "allegro_initialize_cmdline" ); 
  293.     pragma Import( C, Allegro_Exit, "allegro_exit" ); 
  294.     pragma Import( C, Check_CPU, "check_cpu" ); 
  295.     pragma Import( C, CPU_Capabilities, "get_cpu_capabilities" ); 
  296.     pragma Import( C, CPU_Family, "get_cpu_family" ); 
  297.     pragma Import( C, CPU_Model, "get_cpu_model" ); 
  298.     pragma Import( C, Desktop_Color_Depth, "desktop_color_depth" ); 
  299.     pragma Import( C, Install_Allegro, "install_allegro" ); 
  300.     pragma Import( C, OS_Revision, "get_os_revision" ); 
  301.     pragma Import( C, OS_Type, "get_os_type" ); 
  302.     pragma Import( C, OS_Version, "get_os_version" ); 
  303.     pragma Import( C, Set_Close_Button_Callback, "set_close_button_callback" ); 
  304.  
  305. end Allegro;