/*************************************************************************** * 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;
Copyright ©
1996 Simon Johnston &
Addison Wesley Longman