Chapter 9 Examples

/***************************************************************************
 *                             ctest.c
 * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
 *
 * Description: The C code which we bind to using the Ada Interface library.
 * Inputs:  None.
 * Outputs: None.
 ***************************************************************************/
#include <stdio.h>
void putstring(char* str)
{
  puts(str);
}

 

-- ***************************************************************************
-- *                         C_Test1.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Test the interface to C to print a message using a C 
-- *    function.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Interfaces.C;
use type Interfaces.C.char_array;

procedure C_Test1 is

   procedure PutString(S : Interfaces.C.char_array);

   pragma Import(C, PutString, "putstring");

   C_Str : Interfaces.C.char_array := "hello world" &  
                                      Interfaces.C.nul;
begin

   PutString(C_Str);

end C_Test1;

 

-- ***************************************************************************
-- *                         C_Test2.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Test the interface to C to print a message using a C 
-- *    function.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Interfaces.C.Strings;
procedure C_Test2 is

   procedure PutString(S : Interfaces.C.Strings.chars_ptr);

   pragma Import(C, PutString, "putstring");

   Pass_This : String := "hello world";
   C_Str     : Interfaces.C.Strings.chars_ptr;
begin

   C_Str := Interfaces.C.Strings.New_String(Pass_This);

   PutString(C_Str);

   Interfaces.C.Strings.Free(C_Str);

end C_Test2;

 

-- ***************************************************************************
-- *                         C_Test3.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is the client for the "thick" binding to putstring.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with PutString_Binding;

procedure C_Test3 is
begin
   PutString_Binding.Put("hello world");
end C_Test3;

 

-- ***************************************************************************
-- *                         C_Test4.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example uses the C pointers support to call putstring.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Interfaces.C;
use type Interfaces.C.char_array;
with Interfaces.C.Pointers;

procedure C_Test4 is

   package C_char is 
      new Interfaces.C.Pointers(Interfaces.C.size_T,
					   Interfaces.C.char,
					   Interfaces.C.char_array,
					   Interfaces.C.nul);

   procedure PutString(S : C_char.Pointer);

   pragma Import(C, PutString, "putstring");

   C_Str : Interfaces.C.char_array := "hello world 3" & 
                                      Interfaces.C.nul;
begin

   PutString(C_Str(C_Str'First)'Access);

end C_Test4;

 

-- ***************************************************************************
-- *                         Decimal_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Some simple edited IO using decimal types.
-- * Inputs:  None.
-- * Outputs: This test will compile with the GNAT compilers, but not the 
-- *    ObjectAda or AppletMagic compilers which do not support Annex F.
-- ***************************************************************************

with Ada.Text_IO;
with Ada.Text_IO.Editing;
use  Ada;

procedure Decimal_Test is

   type Decimal is delta 0.01 digits 8;

   package Decimal_IO is new Text_IO.Editing.Decimal_Output(Num => Decimal);

   A_Decimal : Decimal;
   Picture   : Text_IO.Editing.Picture;
begin

   Picture := Text_IO.Editing.To_Picture("-9.99");
   A_Decimal := -1.0;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("+9.99");
   A_Decimal := -1.0;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("-9.99");
   A_Decimal := +1.0;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("+9.99");
   A_Decimal := +1.0;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("9999.99");
   A_Decimal := 1234.56;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("9_999.99");
   A_Decimal := 1234.56;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("$_$$9.99-");
   A_Decimal := 1.99;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("$_$$9.99-");
   A_Decimal := 0.50;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("$_$$9.99-");
   A_Decimal := -2.99;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("$*_**9.99");
   A_Decimal := 1.99;
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

   Picture := Text_IO.Editing.To_Picture("$*_**9.99");
   A_Decimal := 123456.99;
   Text_IO.Put_Line("About to raise exception Picture_Error ...");
   Text_IO.Put_Line(Decimal_IO.Image(A_Decimal, Picture));

end Decimal_Test;

 

-- ***************************************************************************
-- *                         Import_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This package specification is an interface between Ada and
-- *    C code.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Interfaces;

package Import_Test1 is

   function  C_Get_Data return Interfaces.Unsigned_32;

   procedure C_Set_Data(Data : Interfaces.Unsigned_32);

   pragma Import(Convention    => C,
		      Entity        => C_Get_Data,
		      External_Name => "getdata",
		      Link_Name     => "_getdata");

   pragma Import(Convention    => C,
		      Entity        => C_Set_Data,
                 External_Name => "setdata");

   procedure Data_Changed;

   pragma Export(Convention    => C,
		      Entity        => Data_Changed,
		      External_Name => "datachanged",
		      Link_Name     => "_datachanged");

   type Data_2 is
      record
	    A : Integer;
      end record;

   pragma Convention(Convention => C,
		          Entity => Data_2);

   pragma Linker_Options("data.obj");

end Import_Test1;

 

-- ***************************************************************************
-- *                         Pos.ads
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: The Interface to our Point of Sale C API.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Interfaces.C;
with Interfaces.C.Pointers;

package Pos is

   type    BYTE        is new Interfaces.C.Unsigned_Char;
   type    PBYTE       is access all BYTE;
   subtype USHORT      is Interfaces.C.Unsigned_Short;
   type    PUSHORT     is access all USHORT;

   type BYTEARRAY1 is array (USHORT range ) of aliased BYTE;
   package BYTEARRAY2 is 
      new Interfaces.C.Pointers(USHORT,
                                BYTE,
                                BYTEARRAY1,
                                BYTE(0));
   subtype BYTEARRAY is BYTEARRAY2.Pointer;

   package CHARARRAY is 
      new Interfaces.C.Pointers(Interfaces.C.size_t,
                                Interfaces.C.char,
                                Interfaces.C.char_array,
                                Interfaces.C.nul);
   subtype PSZ is CHARARRAY.Pointer;

   -- -------------------------------------------
   -- API Version, used to check calls.
   -- 
   API_VERSION : constant := 255;

   -- -------------------------------------------
   -- Devices.
   --
   type UNIT_ID is (UNIT_NONE,
		    	   UNIT_ALL,
		    	   UNIT_POS_KEYBOARD,
		    	   UNIT_PC_KEYBOARD,
		    	   UNIT_ALARM,
		    	   UNIT_MSR,
		    	   UNIT_KEYLOCK,
		    	   UNIT_MAIN_SCANNER,
		    	   UNIT_HH_SCANNER,
		    	   UNIT_SCALE,
		    	   UNIT_OPER_DISPLAY,
		    	   UNIT_CUST_DISPLAY,
		    	   UNIT_BOTH_DISPLAYS,
		    	   UNIT_RCPT_PRINTER,
		    	   UNIT_AUDT_PRINTER,
		    	   UNIT_BOTH_PRINTERS,
		    	   UNIT_SLIP_PRINTER,
		    	   UNIT_FIRST_CASHDRAWER,
		    	   UNIT_SECOND_CASHDRAWER);

   for UNIT_ID use (UNIT_NONE => -1,
		    	   UNIT_ALL => 0,
		    	   UNIT_POS_KEYBOARD => 1,
		    	   UNIT_PC_KEYBOARD => 2,
		    	   UNIT_ALARM => 3,
		    	   UNIT_MSR => 4,
		    	   UNIT_KEYLOCK => 5,
		    	   UNIT_MAIN_SCANNER => 6,
		    	   UNIT_HH_SCANNER => 7,
		    	   UNIT_SCALE => 8,
		    	   UNIT_OPER_DISPLAY => 9,
		    	   UNIT_CUST_DISPLAY => 10,
		    	   UNIT_BOTH_DISPLAYS => 11,
		    	   UNIT_RCPT_PRINTER => 12,
		    	   UNIT_AUDT_PRINTER => 13,
		    	   UNIT_BOTH_PRINTERS => 14,
		    	   UNIT_SLIP_PRINTER => 15,
		    	   UNIT_FIRST_CASHDRAWER => 16,
		    	   UNIT_SECOND_CASHDRAWER => 17);

   for UNIT_ID'Size use USHORT'Size;

   type PUNIT_ID is access all UNIT_ID;

   -- -------------------------------------------
   -- Error codes.
   --
   type ERROR_CODE is (ERROR_OK,
		       	ERROR_NOT_INITIALISED,
		       	ERROR_ALREADY_INITIALISED,
		       	ERROR_OS_ERROR,
		       	ERROR_COMMAND_INVALID,
		       	ERROR_COMMAND_DATA_ERROR,
		       	ERROR_DEVICE_INVALID,
		       	ERROR_DEVICE_WRITE_FAILED,
		       	ERROR_DEVICE_FAILURE,
		       	ERROR_DEVICE_OFFLINE,
		       	ERROR_DEVICE_SEQUENCE_ERR,
		       	ERROR_DEVICE_STATUS_CHANGED,
		       	ERROR_KEYBOARD_MULTIPLE_KEYS,
		       	ERROR_MSR_INVALID_TRACK,
		       	ERROR_MSR_MULTIPLE_TRACKS,
		       	ERROR_PRINTER_FORMAT_ERR,
	       		ERROR_SCALE_ILLEGAL_WEIGHT,
		       	ERROR_SCALE_ZERO_DETECTED,
		       	ERROR_SCALE_NOT_ZEROED,
		       	ERROR_SCALE_WEIGHT_NOT_REMOVED,
		       	ERROR_SCALE_VERIFY_FAILED,
		       	ERROR_SCALE_WEIGHT_NOT_STABLE,
		       	ERROR_SLIP_SEQUENCE_ERR);

   for ERROR_CODE use (ERROR_OK => 0,
		       	ERROR_NOT_INITIALISED => 1,
		       	ERROR_ALREADY_INITIALISED => 2,
		       	ERROR_OS_ERROR => 3,
		       	ERROR_COMMAND_INVALID => 4,
		       	ERROR_COMMAND_DATA_ERROR => 5,
		       	ERROR_DEVICE_INVALID => 6,
		       	ERROR_DEVICE_WRITE_FAILED => 7,
		       	ERROR_DEVICE_FAILURE => 8,
		       	ERROR_DEVICE_OFFLINE => 9,
		       	ERROR_DEVICE_SEQUENCE_ERR => 10,
		       	ERROR_DEVICE_STATUS_CHANGED => 11,
		       	ERROR_KEYBOARD_MULTIPLE_KEYS => 12,
		       	ERROR_MSR_INVALID_TRACK => 13,
		       	ERROR_MSR_MULTIPLE_TRACKS => 14,
		       	ERROR_PRINTER_FORMAT_ERR => 15,
		       	ERROR_SCALE_ILLEGAL_WEIGHT => 16,
		       	ERROR_SCALE_ZERO_DETECTED => 17,
		       	ERROR_SCALE_NOT_ZEROED => 18,
		       	ERROR_SCALE_WEIGHT_NOT_REMOVED => 19,
		       	ERROR_SCALE_VERIFY_FAILED => 20,
		       	ERROR_SCALE_WEIGHT_NOT_STABLE => 21,
		       	ERROR_SLIP_SEQUENCE_ERR => 22);

   for ERROR_CODE'Size use USHORT'Size;

   type PERROR_CODE is access all ERROR_CODE;

   -- -------------------------------------------
   -- API Control Functions.
   --
   function Initialise
     (ApiVersion :    PUSHORT)
      return ERROR_CODE;

   pragma Import(Stdcall, Initialise, "PosInitialise");

   procedure TerminatePoS
     (TermCode : in USHORT);

   pragma Import(Stdcall, TerminatePoS, "PosTerminate");

   function SystemError
     return ERROR_CODE;

   pragma Import(Stdcall, SystemError, "PosSystemError");

   -- -------------------------------------------
   -- The API Read Function.
   --
   MAX_BUFFER_LENGTH : constant USHORT := 512;

   function Read
     (Buffer	    : in BYTEARRAY;
      BufferLength   : in USHORT;
      ReturnedUnit   : in PUNIT_ID;
      ReturnedLength : in PUSHORT)
      return ERROR_CODE;
   
   pragma Import(Stdcall, Read, "PosRead");
  
   -- -------------------------------------------
   -- General Device Functions.
   --
   type DEVICE_CMD is (RESET,
                       INITIALISE,
                       FLUSH,
                       ONLINE);

   for DEVICE_CMD use (RESET => 0,
                       INITIALISE => 1,
                       FLUSH => 2,
                       ONLINE => 3);

   function DeviceControl
     (Unit    : in  UNIT_ID;
      Command : in DEVICE_CMD)
      return ERROR_CODE;

   pragma Import(Stdcall, DeviceControl, "PosDeviceControl");

   type DEVICE_STATUS is
      record
         DeviceAvailable : Boolean;
         DeviceOnLine    : Boolean;
         HandlerEnabled  : Boolean;
         ExDeviceStatus  : BYTE;
      end record;
   pragma Convention(C, DEVICE_STATUS);

   type PDEVICE_STATUS is access all DEVICE_STATUS;

   for DEVICE_STATUS use
      record
         DeviceAvailable at 0 range 0 .. 1;
         DeviceOnLine    at 0 range 1 .. 2;
         HandlerEnabled  at 0 range 2 .. 3;
         ExDeviceStatus  at 1 range 0 .. 7;
      end record;

   function DeviceStatus
     (Unit    : in UNIT_ID;
      Command : in PDEvICE_STATUS)
      return ERROR_CODE;
 
   pragma Import(Stdcall, DeviceStatus, "PosDeviceStatus");

   -- -------------------------------------------
   -- Alarm Device Functions.
   --
   type ALARM_TONE is
      record
         Duration : USHORT;
         Pitch    : USHORT;
         Volume   : USHORT;
      end record;
   pragma Convention(C, ALARM_TONE);
 
   type ALARM_CONFIG is
      record
         Tone1            : ALARM_TONE;
         Tone2            : ALARM_TONE;
         SupportsTone2     : Boolean;
         SupportsInterrupt : Boolean;
      end record;
   pragma Convention(C, ALARM_CONFIG);
   type PALARM_CONFIG is access all ALARM_CONFIG;

   for ALARM_CONFIG use
      record
         Tone1             at 0  range 0 .. 47;
         Tone2             at 6  range 0 .. 47;
         SupportsTone2     at 12 range 0 .. 1;
         SupportsInterrupt at 12 range 1 .. 2;
      end record;

   function AlarmConfig
     (Unit         : in UNIT_ID;
      ConfigRecord : in PALARM_CONFIG)
      return ERROR_CODE;

   pragma Import(Stdcall, AlarmConfig, "PosAlarmConfig");
 
   function AlarmSound
     (Unit        : in UNIT_ID;
      RepeatValue : in USHORT)
      return ERROR_CODE;

   pragma Import(Stdcall, AlarmSound, "PosAlarmSound");
 
   -- -------------------------------------------
   -- Display Device Functions.
   --
   FADE_ON  : constant := 1;
   FADE_OFF : constant := 0;

   type DISPLAY_CONFIG is
      record
         NumberOfLines     : USHORT;
         CharactersPerLine : USHORT;
         NumberOfLEDs      : USHORT;
         SupportsScrolling : Boolean;
         SupportsFade      : Boolean;
      end record;
   pragma Convention(C, DISPLAY_CONFIG);
   type PDISPLAY_CONFIG is access all DISPLAY_CONFIG;

   for DISPLAY_CONFIG use
      record
         NumberOfLines     at 0 range 0 .. 15;
         CharactersPerLine at 2 range 0 .. 15;
         NumberOfLEDs      at 4 range 0 .. 15;
         SupportsScrolling at 6 range 0 .. 1;
         SupportsFade      at 6 range 1 .. 2;
      end record;

   function DisplayConfig
     (Unit         : in UNIT_ID;
      ConfigRecord : in PDISPLAY_CONFIG)
      return ERROR_CODE;

   pragma Import(Stdcall, DisplayConfig, "PosDisplayConfig");

   function DisplayText 
     (Unit         : in UNIT_ID;
      LineNumber   : in USHORT;
      ColumnNumber : in USHORT;
      TextBuffer   : in PSZ)
      return ERROR_CODE;

   pragma Import(Stdcall, DisplayText, "PosDisplayText");

   function DisplayLed
      (Unit     : in UNIT_ID;
       LedState : in USHORT)
       return ERROR_CODE;

   pragma Import(Stdcall, DisplayLed, "PosDisplayLed");
 
   -- -------------------------------------------
   -- Display Device Functions.
   --
   DRAWER_OPEN   : constant := 1;
   DRAWER_CLOSED : constant := 0;

   function OpenDrawer
     (Unit : in UNIT_ID)
      return ERROR_CODE;

   pragma Import(Stdcall, OpenDrawer, "PosCashdrawerOpen");

   function LockDrawer
     (Unit : in UNIT_ID;
      On   : in Boolean)
      return ERROR_CODE;

   pragma Import(Stdcall, LockDrawer, "PosCashdrawerLock");

   -- -------------------------------------------
   -- MSR not used, binding not included
   --

   -- -------------------------------------------
   -- Port handler not used, binding not included
   --

   -- -------------------------------------------
   -- Display Device Functions.
   --
   PAPER_LOW      : constant := 1;
   PAPER_BACK     : constant := 0;
   SLIP_PAPER_IN  : constant := 2;
   SLIP_PAPER_OUT : constant := 0;

   type PRINTER_CAPS is (EPC_WIDE_ON,
                         EPC_WIDE_OFF,
                         EPC_TALL_ON,
                         EPC_TALL_OFF,
                         EPC_BOLD_ON,
                         EPC_BOLD_OFF,
                         EPC_ITALICS_ON,
                         EPC_ITALICS_OFF,
                         EPC_SIDEWAYS_ON,
                         EPC_SIDEWAYS_OFF,
                         EPC_INVERTED_ON,
                         EPC_INVERTED_OFF);

   for PRINTER_CAPS use (EPC_WIDE_ON => 16,
                         EPC_WIDE_OFF => 17,
                         EPC_TALL_ON => 18,
                         EPC_TALL_OFF => 19,
                         EPC_BOLD_ON => 20,
                         EPC_BOLD_OFF => 21,
                         EPC_ITALICS_ON => 22,
                         EPC_ITALICS_OFF => 23,
                         EPC_SIDEWAYS_ON => 24,
                         EPC_SIDEWAYS_OFF => 25,
                         EPC_INVERTED_ON => 26,
                         EPC_INVERTED_OFF => 27);

   type PRINTER_CONFIG is
      record
         NumberOfLines          : USHORT;
         CharactersPerLine      : USHORT;
         CutMargin              : USHORT;
         SupportsPaperCut       : Boolean;
         SupportsPaperPerforate : Boolean;
         SupportsWide           : Boolean;
         SupportsTall           : Boolean;
         SupportsBold           : Boolean;
         SupportsItalic         : Boolean;
         SupportsSideways       : Boolean;
         SupportsInverted       : Boolean;
      end record;
   pragma Convention(C, PRINTER_CONFIG);
   type PPRINTER_CONFIG is access all PRINTER_CONFIG;

   for PRINTER_CONFIG use
      record
         NumberOfLines          at 0 range 0 .. 15;
         CharactersPerLine      at 2 range 0 .. 15;
         CutMargin              at 4 range 0 .. 15;
         SupportsPaperCut       at 6 range 0 .. 1;
         SupportsPaperPerforate at 6 range 1 .. 2;
         SupportsWide           at 6 range 2 .. 3;
         SupportsTall           at 6 range 3 .. 4;
         SupportsBold           at 6 range 4 .. 5;
         SupportsItalic         at 6 range 5 .. 6;
         SupportsSideways       at 6 range 6 .. 7;
         SupportsInverted       at 6 range 7 .. 8;
      end record;

   function PrinterConfig
     (Unit         : in UNIT_ID;
      ConfigRecord : in PPRINTER_CONFIG)
      return ERROR_CODE;

   pragma Import(Stdcall, PrinterConfig, "PosPrinterConfig");

   function PrintText
     (Unit            : in UNIT_ID;
      LinefeedsBefore : in USHORT;
      LinefeedsAfter  : in USHORT;
      TextBuffer      : in PSZ)
      return ERROR_CODE;

   pragma Import(Stdcall, PrintText, "PosPrintText");

   function PrinterAdvance
     (Unit          : in UNIT_ID;
      NumberOfLines : in BYTE)
      return ERROR_CODE;

   pragma Import(Stdcall, PrinterAdvance, "PosPrinterAdvance");

   function PrinterCut
     (Unit          : in UNIT_ID;
      PerforateOnly : in Boolean)
      return ERROR_CODE;

   pragma Import(Stdcall, PrinterCut, "PosPrinterCut");

   type SLIPPRINTER_CMD is (OPEN_JAWS,
                            CLOSE_JAWS,
                            ROLL_PAPER_IN,
                            EJECT_PAPER);

   for SLIPPRINTER_CMD use (OPEN_JAWS => 0,
                            CLOSE_JAWS => 1,
                            ROLL_PAPER_IN => 2,
                            EJECT_PAPER => 3);

   function SlipPrinterCommand
     (Unit    : in UNIT_ID;
      Command : in SLIPPRINTER_CMD)
      return ERROR_CODE;

   pragma Import(Stdcall, SlipPrinterCommand,
                          "PosSlipPrinterCommand");

   -- -------------------------------------------
   -- Weigh Scale not used, binding not included
   --

end Pos;

 

-- ***************************************************************************
-- *                         PutString_Binding.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is a "thick" binding which encapsulates the call to
-- *    the underlying interface.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

package PutString_Binding is

   procedure Put(S : String);
end PutString_Binding;

 

-- ***************************************************************************
-- *                         PutString_Binding.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is a "thick" binding, one which encapsulates the call
-- *    to the underlying interface.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Interfaces.C.Strings;
package body PutString_Binding is

   procedure PutString(S : Interfaces.C.Strings.chars_ptr);
   pragma Import(C, PutString, "putstring");

   procedure Put(S : String) is
      C_Str     : Interfaces.C.Strings.chars_ptr;
   begin
      C_Str := Interfaces.C.Strings.New_String(S);
      PutString(C_Str);
      Interfaces.C.Strings.Free(C_Str);
   end Put;

end PutString_Binding;

 

-- ***************************************************************************
-- *                         Remote_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Shows the pragmas used for the distributed systems annex.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

package Remote_Test is
   pragma Remote_Call_Interface(Remote_Test);

   procedure First_Remote;
   function  Second_Remote return Integer;

   procedure Third_Remote;
   pragma Asynchronous(Third_Remote);

   type Remote_Type is tagged private;
   subtype Remote_Type_Class is Remote_Type'Class;

   procedure Fourth_Remote(Operand : Remote_Type_Class);

private
   type Remote_Type is tagged null record;

end Remote_Test;

 

-- ***************************************************************************
-- *                         Task_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example shows the use of the Ada.Task_Attributes
-- *    package which allows you to add arbitrary attributes to tasks.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Ada.Task_Attributes;
with Ada.Text_IO;
use  Ada;

procedure Task_Test is

   package Threaded is new Task_Attributes(Boolean,
					              True);
   task type X is
      entry Start;
   end X;

   task body X is
   begin
      Threaded.Set_Value(False);
      accept Start do
	    null;
      end Start;
   end X;

   An_X : X;
begin
   Text_IO.Put_Line("Current Task Value = " &
		         Boolean'Image(Threaded.Value));

   Text_IO.Put_Line("An_X Value = " &
		         Boolean'Image(Threaded.Value(An_X'Identity)));
end Task_Test;

Contents Page

Copyright © 1996 Simon Johnston &
Addison Wesley Longman