I am programming a Windows CE 6 device (Motorola MC3100 scanner Terminal). Using Lazarus FPC to compile it.
After 3 weeks work I reluctantly post here in the hope someone can suggest why I am getting garbled output from the serial port.
The code I am using is posted below. This is the standard code I have found from several places.
The OpenPort works OK.
When I send the string using SendString('ABCDEF') I get garbled input to the PC Serial port such as:
4[#131][#26][#0][#0][#0][#0] (the bracketed data indicates that it is a non-printable character ASCII Code)
Obviously it is connecting to the port OK AND it is sending the correct no of characters (7).
I have tried all combinations of Baud Rate, Data Bits, Parity and Stop Bits without any joy. Also tried changing cable, on a different PC etc.
Could it be I need to set something else in the DCB?
Any help or suggestions would be GREATLY appreciated.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
Windows, LResources;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
function OpenPort(ComPort:String;BaudRate,ByteSize,Parity,StopBits:integer):String;
procedure SendString(str:String);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
cc:TCOMMCONFIG;
Connected:Boolean;
implementation
{$R *.lfm}
var F: TextFile;
var hComm: THandle;
str: String;
lrc: LongWord;
{ TForm1 }
function
OpenPort(ComPort:String;BaudRate,ByteSize,Parity,StopBits:integer):String;
var
cc:TCOMMCONFIG;
SWide:WideString;
Port:LPCWSTR;
begin
SWide:=ComPort;
Port:=PWideChar(SWide);
result:='';
if (1=1) then begin
Connected:=False;
hComm:=CreateFile(Port, GENERIC_READ or GENERIC_WRITE,0, nil,OPEN_EXISTING,0,0);
if (hComm = INVALID_HANDLE_VALUE) then begin
ShowMessage('Fail to Open');
exit;
end;
GetCommState(hComm,cc.dcb);
cc.dcb.BaudRate:=BaudRate;
cc.dcb.ByteSize:=ByteSize;
cc.dcb.Parity:=Parity;
cc.dcb.StopBits:=StopBits;
if not SetCommState(hComm, cc.dcb) then begin
result:='SetCommState Error!';
CloseHandle(hComm);
exit;
end;
Connected:=True;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenPort('COM1:',9600,8,0,0);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SendString('ABCDEFG');
end;
procedure TForm1.SendString(str:String);
var
lrc:LongWord;
begin
if (hComm=0) then exit;
try
if not PurgeComm(hComm, PURGE_TXABORT or PURGE_TXCLEAR) then
raise Exception.Create('Unable to purge com: ');
except
Exit;
end;
WriteFile(hComm,str,Length(str), lrc, nil);
end;
end.
Found the answer to this.
WriteFile(hComm,str,Length(str), lrc, nil);
The "str" parameter was in fact a pointer to the string, not the string itself
Changing it to this works.
WriteFile(hComm,str[1],Length(str), lrc, nil);
Related
The question is about the performance of protected type and entry using the GNAT compiler on Linux. Mutex is only used as an example (Ada does not need it).
I compared the performance of Ada Mutex implementation from Rosetta Code
(https://rosettacode.org/wiki/Mutex#Ada) to a very simple C/pthread implementation called from Ada using import and C interface.
It turned out the Ada protected type + entry was 36.8x times slower.
I know that GNAT may go through its run time library and eventually ends up
calling OS primitives s.a. pthread. I excepted some overhead but not that much.
The question is: Why?
Just in case - this is my simple pthread implementation:
-- cmutex.ads
package CMutex is
procedure Lock with
Import => True,
Convention => C,
External_Name => "mutex_lock";
procedure Unlock with
Import => True,
Convention => C,
External_Name => "mutex_unlock";
end CMutex;
// C code
#include <pthread.h>
static pthread_mutex_t mtx = PTHREAD_MUTEX_INITIALIZER;
void mutex_lock()
{
pthread_mutex_lock(&mtx);
}
void mutex_unlock()
{
pthread_mutex_unlock(&mtx);
}
==== EDIT ===
Adding minimal reproachable code. It is a single thread (just for test), the dummy variable is to prevent the optimizer from optimizing the entire loop out.
The test code for the pthread (cmutex) above is:
with Text_IO; use Text_IO;
with CMutex;
procedure test is
dummy : Integer := 0;
begin
for i in 1 .. 100_000_000 loop
CMutex.Lock;
dummy := dummy + 1;
CMutex.Unlock;
end loop;
Text_IO.Put_Line(Integer'image(dummy));
end test;
And the test code for the protected type + entry example is:
with Text_IO; use Text_IO;
with Ada_Mutex;
procedure test1 is
dummy : Integer := 0;
mtx : Ada_Mutex.Mutex;
begin
for i in 1 .. 100_000_000 loop
mtx.Seize;
dummy := dummy + 1;
mtx.Release;
end loop;
Text_IO.Put_Line(Integer'image(dummy));
end test1;
Where Ada_Mutex is a package containing the example form Rosetta code:
package Ada_Mutex is
protected type Mutex is
entry Seize;
procedure Release;
private
Owned : Boolean := False;
end Mutex;
end Ada_mutex;
--------------------------------
package body Ada_Mutex is
protected body Mutex is
entry Seize when not Owned is
begin
Owned := True;
end Seize;
procedure Release is
begin
Owned := False;
end Release;
end Mutex;
end Ada_Mutex;
Running time of the code that using the pthread mutex is (in Intel NUC i7):
$ time ./test
100000000
real 0m0.557s
user 0m0.553s
sys 0m0.005s
And the code that uses protected type and entry:
$ time ./test1
100000000
real 0m19.009s
user 0m19.005s
sys 0m0.005s
With no optimization (-O0) times are:
real 0m0.746s
user 0m0.746s
sys 0m0.000s
and
real 0m20.173s
user 0m20.172s
sys 0m0.000s
For pthread and protected type+entry respectively.
Note that the user time ~= real time, which means the processor
was busy (it did not idle, or otherwise yield control)
I did the problem and when I try to compile it said that identifier expected but I did all right.
with.Ada.TexT_IO;use Ada.Text_IO;
Procedure Isort1 is
type node;
type link is access node;
type node is
record
value:integer;
rest:Character;
next:link;
end record;
package IntIO is new Ada.Text_IO.Integer_IO(integer);use IntIO;
int:integer;
l:link;
pt:array(1..100)of link;
ch:character;
begin
for i in 1..10 loop pt(i):=null;
end loop;
loop
put("put an integer key (1 thru 10),99 to stop ");
get(int);
exit when int=99;
put("enter the other info,1 char ");
get(ch);
pt(int):= new node'(int,ch,pt(int));
end loop;
for i in 1..10 loop
i:=pt(i);
while I /=null loop
put(I.value);
put("... ");
put(I.rest);
new_line;
I:=I.next;
end loop;
end loop;
end Isort1;
Your assumption that you "did all right" is clearly wrong.
It appears that you are learning Ada after knowing some other programming language. You appear to be mixing ideas from other language(s) into your Ada code.
Let's organize and indent your code first.
with.Ada.TexT_IO;use Ada.Text_IO;
Procedure Isort1 is
type node;
type link is access node;
type node is
record
value:integer;
rest:Character;
next:link;
end record;
package IntIO is new Ada.Text_IO.Integer_IO(integer);use IntIO;
int:integer;
l:link;
pt:array(1..100)of link;
ch:character;
begin
for i in 1..10 loop pt(i):=null;
end loop;
loop
put("put an integer key (1 thru 10),99 to stop ");
get(int);
exit when int=99;
put("enter the other info,1 char ");
get(ch);
pt(int):= new node'(int,ch,pt(int));
end loop;
for i in 1..10 loop
i:=pt(i);
while I /=null loop
put(I.value);
put("... ");
put(I.rest);
new_line;
I:=I.next;
end loop;
end loop;
end Isort1;
Your first line begins with "with.Ada.TexT_IO;". It should say "with Ada.Text_I0;". Capitalization differences are not the problem. The problem is the period '.' following the reserved word "with".
Once that problem is fixed the compiler will tell you that you have an error in the line containing
i:=pt(i);
The error messages from the compiler are shown in the screen capture below.
It appears that you want the variable I to contain an instance of type node, but variable I is never declared and is never assigned a value.
I've written an Ada program which encrypts files. It reads them block by block to conserve memory on the target machine. Unfortunately Ada's Directories library reads filesizes in a Long_Integer, limiting the read to almost 2GB files. When trying to read files over 2GB, the program fails at runtime getting a stack overflow error.
The documentation for it here is the origin of my understanding above. How can I read a filesize into a type I define myself? One I can make requiring something like 25 bytes to increase the cap to 100GB.
I just posted GCC bug 55119 on this.
While you're waiting (!), the code below works on Mac OS X Mountain Lion. On Windows, it's more complicated; see adainclude/adaint.{c,h}.
The Ada spec:
with Ada.Directories;
package Large_Files is
function Size (Name : String) return Ada.Directories.File_Size;
end Large_Files;
and body (copied in part from Ada.Directories):
with GNAT.OS_Lib;
with System;
package body Large_Files is
function Size (Name : String) return Ada.Directories.File_Size
is
C_Name : String (1 .. Name'Length + 1);
function C_Size (Name : System.Address) return Long_Long_Integer;
pragma Import (C, C_Size, "large_file_length");
begin
if not GNAT.OS_Lib.Is_Regular_File (Name) then
raise Ada.Directories.Name_Error
with "file """ & Name & """ does not exist";
else
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
return Ada.Directories.File_Size (C_Size (C_Name'Address));
end if;
end Size;
end Large_Files;
and the C interface:
/* large_files_interface.c */
#include <sys/stat.h>
long long large_file_length (const char *name)
{
struct stat statbuf;
if (stat(name, &statbuf) != 0) {
return 0;
} else {
return (long long) statbuf.st_size;
}
}
You might need to use struct stat64 and stat64() on other Unix systems.
Compile the C interface as normal, then add -largs large_files_interface.o to your gnatmake command line.
EDIT: on Mac OS X (and Debian), which are x86_64 machines, sizeof(long) is 8 bytes; so the comment in adaint.c is misleading and Ada.Directories.Size can return up to 2**63-1.
I am trying to set a service's failure actions using Inno Setup's Pascal scripting language. I receive the classic "access violation at address..." error. Seems that it is impossible because the language don't have any support to pointers. Any ideas? Here is the code snippet:
type
TScAction = record
aType1 : Longword;
Delay1 : Longword;
aType2 : Longword;
Delay2 : Longword;
aType3 : Longword;
Delay3 : Longword;
end;
type
TServiceFailureActionsA = record
dwResetPeriod : DWORD;
pRebootMsg : String;
pCommand : String;
cActions : DWORD;
saActions : TScAction;
end;
function ChangeServiceConfig2(hService: Longword; dwInfoLevel: Longword; lpInfo: TServiceFailureActionsA): BOOL;
external 'ChangeServiceConfig2A#advapi32.dll stdcall';
procedure SimpleChangeServiceConfig(AService: string);
var
SCMHandle: Longword;
ServiceHandle: Longword;
sfActions: TServiceFailureActionsA;
sActions: TScAction;
begin
try
SCMHandle := OpenSCManager('', '', SC_MANAGER_ALL_ACCESS);
if SCMHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenSCManager: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
ServiceHandle := OpenService(SCMHandle, AService, SERVICE_ALL_ACCESS);
if ServiceHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenService: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
sActions.aType1 := SC_ACTION_RESTART;
sActions.Delay1 := 60000; // First.nDelay: in milliseconds, MMC displayed in minutes
sActions.aType2 := SC_ACTION_RESTART;
sActions.Delay2 := 60000;
sActions.aType3 := SC_ACTION_RESTART;
sActions.Delay3 := 60000;
sfActions.dwResetPeriod := 1; // in seconds, MMC displayes in days
//sfActions.pRebootMsg := null; // reboot message unchanged
//sfActions.pCommand := null; // command line unchanged
sfActions.cActions := 3; // first, second and subsequent failures
sfActions.saActions := sActions;
if not ChangeServiceConfig2(
ServiceHandle, // handle to service
SERVICE_CONFIG_FAILURE_ACTIONS, // change: description
sfActions) // new description
then
RaiseException('SimpleChangeServiceConfig#ChangeServiceConfig2: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
finally
if ServiceHandle <> 0 then
CloseServiceHandle(ServiceHandle);
end;
finally
if SCMHandle <> 0 then
CloseServiceHandle(SCMHandle);
end;
except
ShowExceptionMessage;
end;
end;
You have two problems in your script. Like Deanna suggested you have to use the var keyword in the declaration of the lpInfo parameter.
Also you need to change the TScAction type to an array with two elements.
Here is my script that you can include in your Inno Setup script.
const
SERVICE_CONFIG_DELAYED_AUTO_START_INFO = 3; //The lpInfo parameter is a pointer to a SERVICE_DELAYED_AUTO_START_INFO structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_DESCRIPTION = 1; //The lpInfo parameter is a pointer to a SERVICE_DESCRIPTION structure.
SERVICE_CONFIG_FAILURE_ACTIONS = 2; //The lpInfo parameter is a pointer to a SERVICE_FAILURE_ACTIONS structure.
//If the service controller handles the SC_ACTION_REBOOT action, the caller must have
// the SE_SHUTDOWN_NAME privilege. For more information, see Running with Special Privileges.
SERVICE_CONFIG_FAILURE_ACTIONS_FLAG = 4; //The lpInfo parameter is a pointer to a SERVICE_FAILURE_ACTIONS_FLAG structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_PREFERRED_NODE = 9; //The lpInfo parameter is a pointer to a SERVICE_PREFERRED_NODE_INFO structure.
//Windows Server 2008, Windows Vista, Windows Server 2003, and Windows XP: This value is not supported.
SERVICE_CONFIG_PRESHUTDOWN_INFO = 7; //The lpInfo parameter is a pointer to a SERVICE_PRESHUTDOWN_INFO structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_REQUIRED_PRIVILEGES_INFO = 6; //The lpInfo parameter is a pointer to a SERVICE_REQUIRED_PRIVILEGES_INFO structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_SERVICE_SID_INFO = 5; //The lpInfo parameter is a pointer to a SERVICE_SID_INFO structure.
SERVICE_CONFIG_TRIGGER_INFO = 8; //The lpInfo parameter is a pointer to a SERVICE_TRIGGER_INFO structure.
//This value is not supported by the ANSI version of ChangeServiceConfig2.
//Windows Server 2008, Windows Vista, Windows Server 2003, and Windows XP: This value is not supported until Windows Server 2008 R2.
SC_ACTION_NONE = 0; // No action.
SC_ACTION_REBOOT = 2; // Reboot the computer.
SC_ACTION_RESTART = 1; // Restart the service.
SC_ACTION_RUN_COMMAND = 3; // Run a command.
type
TScAction = record
aType1 : Longword;
Delay1 : Longword;
end;
type
TServiceFailureActionsA = record
dwResetPeriod : DWORD;
pRebootMsg : String;
pCommand : String;
cActions : DWORD;
saActions : array of TScAction;
end;
function ChangeServiceConfig2(
hService: Longword;
dwInfoLevel: Longword;
var lpInfo: TServiceFailureActionsA): BOOL;
external 'ChangeServiceConfig2A#advapi32.dll stdcall';
procedure SimpleChangeServiceConfig(AService: string);
var
SCMHandle: Longword;
ServiceHandle: Longword;
sfActions: TServiceFailureActionsA;
sActions: array of TScAction;
begin
SetArrayLength(sActions ,3);
try
SCMHandle := OpenSCManager('', '', SC_MANAGER_ALL_ACCESS);
if SCMHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenSCManager: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
ServiceHandle := OpenService(SCMHandle, AService, SERVICE_ALL_ACCESS);
if ServiceHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenService: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
sActions[0].aType1 := SC_ACTION_RESTART;
sActions[0].Delay1 := 60000; // First.nDelay: in milliseconds, MMC displayed in minutes
sActions[1].aType1 := SC_ACTION_RESTART;
sActions[1].Delay1 := 60000;
sActions[2].aType1 := SC_ACTION_NONE;
sActions[2].Delay1 := 60000;
sfActions.dwResetPeriod := 1; // in seconds, MMC displayes in days
//sfActions.pRebootMsg := null; // reboot message unchanged
//sfActions.pCommand := null; // command line unchanged
sfActions.cActions := 3; // first, second and subsequent failures
sfActions.saActions := sActions;
if not ChangeServiceConfig2(
ServiceHandle, // handle to service
SERVICE_CONFIG_FAILURE_ACTIONS, // change: description
sfActions) // new description
then
RaiseException('SimpleChangeServiceConfig#ChangeServiceConfig2: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
finally
if ServiceHandle <> 0 then
CloseServiceHandle(ServiceHandle);
end;
finally
if SCMHandle <> 0 then
CloseServiceHandle(SCMHandle);
end;
except
ShowExceptionMessage;
end;
end;
Try using the var keyword in the declaration for the lpInfo parameter to specify that it's to pass a pointer to the structure to the function.
I have two ada files shown below
A1.ada
procedure KOR616 is
I : Integer := 3;
procedure Lowest_Level( Int : in out Integer );
pragma Inline( Lowest_Level );
procedure Null_Proc is
begin
null;
end;
procedure Lowest_Level( Int : in out Integer ) is
begin
if Int > 0 then
Int := 7;
Null_Proc;
else
Int := Int + 1;
end if;
end;
begin
while I < 7 loop
Lowest_Level( I );
end loop;
end;
Next shown below is B1.ada
procedure Lowest_Level( Int : in out Integer );
pragma Inline( Lowest_Level );
procedure Lowest_Level( Int : in out Integer ) is
procedure Null_Proc is
begin
null;
end;
begin
if Int > 0 then
Int := 7;
Null_Proc;
else
Int := Int + 1;
end if;
end Lowest_Level;
with Lowest_Level;
procedure KOR618 is
I : Integer := 3;
begin
while I < 7 loop
Lowest_Level( I );
end loop;
end;
Is there any difference between these two files?
As written, KOR616 (A1) and KOR618 (B1) are going to have the same effect. The difference is a matter of visibility (and the compiled code will be different, of course, but I doubt that matters).
In A1, the bodies of both Null_Proc and Lowest_Level can see I, but nothing outside KOR616 can see them. Also, the body of KOR616 can see Null_Proc.
In B1, Lowest_Level (but not Null_Proc) is visible to the whole program, not just KOR618.
In B1, Null_Proc isn't inlined. (It is not within Lowest_Level).
In A1, procedure Null_Proc is not nested in procedure Lowest_Level; in B1, it is nested in procedure Lowest_Level. Regarding pragma Inline, "an implementation is free to follow or to ignore the recommendation expressed by the pragma." I'd expect the in-lining of nested subprograms to be implementation dependent.
Well, the main difference is that in the second example Null_Proc is unavailable outside of Lowest_Level. In the first example, if you felt like it later you could have KOR618 or any other routine you might add later also call Null_Proc.
Generally I don't define routines inside other routines like that unless there is some reason why the inner routine makes no sense outside of the outer routine. The obvious example would be if the inner routine operates on local variables declared in the outer routine (without passing them as parameters).
In this case Null_Proc is about as general an operation as it gets, so I don't see any compelling reason to squirel it away inside Lowest_Level like that. Of course, it doesn't do anything at all, so I don't any compelling reason for it to exist in the first place. :-)