GNAT: The GNU New York University Ada Translator 
by Gavin Smyth

Example 1: 

declare
  Regs: Dpmi_Regs;
begin
  Regs.Ah := 0;
  Regs.Al := Unsigned_Char( Mode );
  Dpmi_Int( 16#10#, Regs );
end;

Example 2: 

Farnspokeb( A_Long_Offset, A_Byte );

Example 3: 

(a)
Asm( Template : String;                    -- Assembly instruction
     Outputs  : Asm_Output_Operand_List;   -- Output operands
     Inputs   : Asm_Input_Operand_List;    -- Input operands
     Clobber  : String  := "";             -- Other touched registers
     Volatile : Boolean := False);

where the operand lists are both lists of associations of expressions to
assembler operands, of the form (for input):

Type'Asm_input( Operand: String; Expression: Type )

(b) 
Asm( "movb %b1,%%fs:(%k0)",
     No_Output_Operands,
     ( Unsigned_Long'Asm_Input( "qi", Local_Offset ),
       Pixel'Asm_Input( "r", Sp( Row, Col ) ) ) );

Example 4: 

Dpmi_Error: exception;  -- Thrown if there is a system problem

Start_Of_Locked_Code, End_Of_Locked_Code: Unsigned_Char;
pragma Import( Asm, Start_Of_Locked_Code, "start_of_locked_code" );
pragma Import( Asm, End_Of_Locked_Code, "end_of_locked_code" );

Code: aliased Dpmi_Mem_Info;

 ...

Dpmi_Get_Segment_Base_Address( My_Cs, Code.Address );
Code.Address := Code.Address + To_Long( Start_Of_Locked_Code'Address );
Code.Size := To_Long( End_Of_Locked_Code'Address ) -
             To_Long( Start_Of_Locked_Code'Address );
if( Dpmi_Lock_Linear_Region( Code'access ) /= 0 ) then
  raise Dpmi_Error;
end if;


Example 5: 

Keys_Pressed: array( Scan_Code ) of Scan_Code;
pragma Import( Asm, Keys_Pressed, "keys" );
pragma Volatile( Keys_Pressed );

Most_Recent_Key: Scan_Code renames Keys_Pressed( 0 );


Listing One
(a) 
key_test.exe: key_test.o dosmemor.o keyinput.o keyintr.o
    gnatbind -x key_test.ali
    gnatlink key_test.ali keyintr.o

dosmemor.o: dosmemor.adb dosmemor.ads
    gcc -c $<
keyinput.o: keyinput.adb keyinput.ads dosmemor.ads
    gcc -c $<
key_test.o: key_test.adb keyinput.ads
    gcc -c $<
keyintr.o: keyintr.s
    gcc -c $<

(b)
key_test.exe: *.adb *.ads keyintr.o
    gnatmake key_test.ali -largs keyintr.o
keyintr.o: keyintr.s
    gcc -c $<

(c)
key_test.exe: key_test.ali keyintr.o
    gnatbind -x key_test.ali
    gnatlink key_test.ali keyintr.o
key_test.ali: *.adb *.ads
    gnatmake -c key_test
keyintr.o: keyintr.s
    gcc -c $<


Listing Two
-- Interface to a subset of the DJGPP specific functions for accessing "DOS"
-- memory and DPMI functions. See the DJGPP documentation and C header files
-- for more information.

with System;
with Interfaces.C; use Interfaces.C;

package Dos_Memory is
  type Byte_Regs is
    record
      Di:       Unsigned_Short;
      Upper_Di: Unsigned_Short;
      Si:       Unsigned_Short;
      Upper_Si: Unsigned_Short;
      Bp:       Unsigned_Short;
      Upper_Bp: Unsigned_Short;
      Cflag:    Unsigned_Long;
      Bl:       Unsigned_Char;
      Bh:       Unsigned_Char;
      Upper_Bx: Unsigned_Short;
      Dl:       Unsigned_Char;
      Dh:       Unsigned_Char;
      Upper_Dx: Unsigned_Short;
      Cl:       Unsigned_Char;
      Ch:       Unsigned_Char;
      Upper_Cx: Unsigned_Short;
      Al:       Unsigned_Char;
      Ah:       Unsigned_Char;
      Upper_Ax: Unsigned_Short;
      Flags:    Unsigned_Short;
    end record;
  pragma Convention( C, Byte_Regs );
  type Dpmi_Regs is
    record
      Di:       Unsigned_Short;
      Upper_Di: Unsigned_Short;
      Si:       Unsigned_Short;
      Upper_Si: Unsigned_Short;
      Bp:       Unsigned_Short;
      Upper_Bp: Unsigned_Short;
      Cflag:    Unsigned_Long;
      Bl:       Unsigned_Char;
      Bh:       Unsigned_Char;
      Upper_Bx: Unsigned_Short;
      Dl:       Unsigned_Char;
      Dh:       Unsigned_Char;
      Upper_Dx: Unsigned_Short;
      Cl:       Unsigned_Char;
      Ch:       Unsigned_Char;
      Upper_Cx: Unsigned_Short;
      Al:       Unsigned_Char;
      Ah:       Unsigned_Char;
      Upper_Ax: Unsigned_Short;
      Flags:    Unsigned_Short;
      Es:       Unsigned_Short;
      Ds:       Unsigned_Short;
      Fs:       Unsigned_Short;
      Gs:       Unsigned_Short;
      Ip:       Unsigned_Short;
      Cs:       Unsigned_Short;
      Sp:       Unsigned_Short;
      Ss:       Unsigned_Short;
    end record;
  pragma Convention( C, Dpmi_Regs );
  type Dpmi_Mem_Info is
    record
      Handle:  Unsigned_Long;
      Size:    Unsigned_Long;
      Address: Unsigned_Long;
    end record;
  pragma Convention( C, Dpmi_Mem_Info );
  type Dpmi_Paddr is
    record
      Offset32: Unsigned_Long;
      Selector: Unsigned_Short;
    end record;
  pragma Convention( C, Dpmi_Paddr );
  type Go32_Info_Block is
    record
      Size_Of_This_Structure_In_Bytes:       Unsigned_Long;
      Linear_Address_Of_Primary_Screen:      Unsigned_Long;
      Linear_Address_Of_Secondary_Screen:    Unsigned_Long;
      Linear_Address_Of_Transfer_Buffer:     Unsigned_Long;
      Size_Of_Transfer_Buffer:               Unsigned_Long;
      Pid:                                   Unsigned_Long;
      Master_Interrupt_Controller_Base:      Unsigned_Char;
      Slave_Interrupt_Controller_Base:       Unsigned_Char;
      Selector_For_Linear_Memory:            Unsigned_Short;
      Linear_Address_Of_Stub_Info_Structure: Unsigned_Long;
      Linear_Address_Of_Original_Psp:        Unsigned_Long;
      Run_Mode:                              Unsigned_Short;
      Run_Mode_Info:                         Unsigned_Short;
    end record;
  pragma Convention( C, Go32_Info_Block );
  procedure Move_Data( Source_Sel: in Integer;Source_Offset:in System.Address;
                       Dest_Sel: in Integer; Dest_Offset: in Integer;
                       Size: in Integer );
  pragma Import( C, Move_Data, "movedata" );
  procedure Int86( Ivec: in Unsigned_Long;
                   Regs_In: in Byte_Regs;
                   Regs_Out: out Byte_Regs );
  pragma Import( C, Int86, "int86" );
  procedure Dpmi_Int( Vector: in Integer; Regs: in out Dpmi_Regs );
  pragma Import( C, Dpmi_Int, "__dpmi_int" );

  function Go32_Conventional_Mem_Selector return Unsigned_Short;
  pragma Import(C, Go32_Conventional_Mem_Selector,
                   "_go32_conventional_mem_selector");
  procedure Farsetsel( Selector: in Unsigned_Short );
  pragma Import( C, Farsetsel, "_farsetsel" );

  procedure Farnspokeb( Offset: in Unsigned_Long; Value: Unsigned_Char );
  pragma Import( C, Farnspokeb, "_farnspokeb" );

  function Dpmi_Lock_Linear_Region(Info: access Dpmi_Mem_Info) return Integer;
  pragma Import( C, Dpmi_Lock_Linear_Region, "__dpmi_lock_linear_region" );

  function Dpmi_Unlock_Linear_Region(Info:access Dpmi_Mem_Info) return Integer;
  pragma Import( C, Dpmi_Unlock_Linear_Region, "__dpmi_unlock_linear_region" );

  function Dpmi_Set_Protected_Mode_Interrupt_Vector( Vector: in Integer;
                                                  Address: access Dpmi_Paddr )
    return Integer;
  pragma Import( C, Dpmi_Set_Protected_Mode_Interrupt_Vector,
                 "__dpmi_set_protected_mode_interrupt_vector" );
  function Dpmi_Get_Protected_Mode_Interrupt_Vector( Vector: in Integer;
                                                  Address: access Dpmi_Paddr )
    return Integer;
  pragma Import( C, Dpmi_Get_Protected_Mode_Interrupt_Vector,
                 "__dpmi_get_protected_mode_interrupt_vector" );
  procedure Dpmi_Get_Segment_Base_Address( Selector: in Unsigned_Short;
                                           Address: out Unsigned_Long );
  pragma Import( C, Dpmi_Get_Segment_Base_Address,
                 "__dpmi_get_segment_base_address" );
  function My_Cs return Unsigned_Short;
  pragma Import( C, My_Cs, "_my_cs" );
  function My_Ds return Unsigned_Short;
  pragma Import( C, My_Ds, "_my_ds" );
  procedure Out_Port_B( Port: in Unsigned_Short; Data: in Unsigned_Char );
  pragma Import( C, Out_Port_B, "outportb" );

  -- This is a new routine - sets the far selector to the one I most
  -- often want, the conventional DOS area.
  procedure Set_Dos_Selector;
  pragma Inline( Set_Dos_Selector );
end Dos_Memory;


Listing Three
-- Plot a shape using only Ada (and a few imported C functions)
with Interfaces.C; use Interfaces.C;
with Dos_Memory;   use Dos_Memory;

package body Sprite is
  procedure Plot( X, Y: in Coord; Sp: in Sprite_Data ) is
    Offset, Local_Offset: Unsigned_Long;
  begin
    Offset := Unsigned_Long( 16#A0000# + Y * 320 + X );
    Set_Dos_Selector;
    for Row in Sp'Range
    loop
      Local_Offset := Offset;
      for Col in Sp'Range( 2 )
      loop
        Farnspokeb( Local_Offset, Unsigned_Char( Sp( Row, Col ) ) );
        Local_Offset := Local_Offset + 1;
      end loop;
      Offset := Offset + 320;
    end loop;
  end Plot;
end Sprite;


