OS: Windows 10
Delphi: 10.4
Начало здесь: http://www.freepascal.ru/forum/viewtopic.php?f=5&t=5811
Данной ссылке уже 10 лет и описанная там проблема так и не была решена, поэтому я рискнул вернуться к этой теме повторно:
Конкретно, проблема возникает при попытке подключения внешнего модуля АЦП E14-140 с использованием фирменной (от L-Card) библиотеки dll lcomp (имеется также библиотека lusbapi, но и с ней возникают аналогичные проблемы).
В комплект программного обеспечения для Delphi от L-Card входит учебная программа 17xxdpr, которая прекрасно компилируется и RAD Studio и правильно работает. Я попытался переписать эту программу под Lazarus, однако тут возникают проблемы, связанные с тем, что интерфейсная dll пытается передавать в программу на Lazarus классы, а именно передается экземпляр класса LUnknown:
- Код: Выделить всё
LUnknown = class
function QueryInterface(const iid:TGUID; out ppv):HRESULT; virtual; stdcall; abstract;
function AddRef:ULONG; virtual; stdcall; abstract;
function Release:ULONG; virtual; stdcall; abstract;
end;
а затем вызовом функции QueryInterface этого класса извлекается ссылка на указатель класса IDaqLDevice = class(LUnknown)
- Код: Выделить всё
type
IDaqLDevice = class(LUnknown)
function inbyte (offset:ULONG; var data:UCHAR; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function inword (offset:ULONG; var data:USHORT; len:ULONG; key:ULONG):ULONG; virtual; stdcall; abstract;
function indword(offset:ULONG; var data:ULONG; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function outbyte (offset:ULONG; var data:UCHAR; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function outword (offset:ULONG; var data:USHORT; len:ULONG; key:ULONG):ULONG; virtual; stdcall; abstract;
function outdword(offset:ULONG; var data:ULONG; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
// Working with MEM ports
function inmbyte (offset:ULONG; var data:UCHAR; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function inmword (offset:ULONG; var data:USHORT; len:ULONG; key:ULONG):ULONG; virtual; stdcall; abstract;
function inmdword(offset:ULONG; var data:ULONG; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function outmbyte (offset:ULONG; var data:UCHAR; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function outmword (offset:ULONG; var data:USHORT; len:ULONG; key:ULONG):ULONG; virtual; stdcall; abstract;
function outmdword(offset:ULONG; var data:ULONG; len:ULONG; key:ULONG ):ULONG; virtual; stdcall; abstract;
function GetWord_DM(Addr:USHORT; var Data:USHORT):ULONG; virtual; stdcall; abstract;
function PutWord_DM(Addr:USHORT; Data:USHORT):ULONG; virtual; stdcall; abstract;
function PutWord_PM(Addr:USHORT; Data:ULONG):ULONG; virtual; stdcall; abstract;
function GetWord_PM(Addr:USHORT; var Data:ULONG):ULONG; virtual; stdcall; abstract;
function GetArray_DM(Addr:USHORT; Count:ULONG; var Data:USHORT):ULONG; virtual; stdcall; abstract;
function PutArray_DM(Addr:USHORT; Count:ULONG; var Data:USHORT):ULONG; virtual; stdcall; abstract;
function PutArray_PM(Addr:USHORT; Count:ULONG; var Data:ULONG):ULONG; virtual; stdcall; abstract;
function GetArray_PM(Addr:USHORT; Count:ULONG; var Data:ULONG):ULONG; virtual; stdcall; abstract;
function SendCommand(Cmd:USHORT):ULONG; virtual; stdcall; abstract;
function PlataTest:ULONG; virtual; stdcall; abstract;
function GetSlotParam(var slPar:SLOT_PAR):ULONG; virtual; stdcall; abstract;
function OpenLDevice:THandle; virtual; stdcall; abstract;
function CloseLDevice:ULONG; virtual; stdcall; abstract;
///
function SetParametersStream(var ap:DAQ_PAR; var UsedSize:ULONG; out Data; out Sync; StreamId:ULONG):ULONG; virtual; stdcall; abstract;
function RequestBufferStream(var Size:ULONG; StreamId:ULONG):ULONG; virtual; stdcall; abstract; //in words
function FillDAQparameters(var ap:DAQ_PAR):ULONG; virtual; stdcall; abstract;
///
function InitStartLDevice:ULONG; virtual; stdcall; abstract;
function StartLDevice:ULONG; virtual; stdcall; abstract;
function StopLDevice:ULONG; virtual; stdcall; abstract;
function LoadBios(FileName:PAnsiChar):ULONG; virtual; stdcall; abstract;
{
function InputADC(Chan:USHORT; var Data:USHORT):ULONG; virtual; stdcall; abstract;
function InputTTL(var Data:ULONG; Mode:ULONG):ULONG; virtual; stdcall; abstract;
function OutputTTL(Data:ULONG; Mode:ULONG):ULONG; virtual; stdcall; abstract;
function ConfigTTL(Data:ULONG):ULONG; virtual; stdcall; abstract;
function OutputDAC(Data:ShortInt; Mode:ULONG):ULONG; virtual; stdcall; abstract;
function ConfigDAC(Mode:ULONG; Number:ULONG):ULONG; virtual; stdcall; abstract;
}
function IoAsync(var sp:DAQ_PAR):ULONG; virtual; stdcall; abstract;
function ReadPlataDescr(var pd):ULONG; virtual; stdcall; abstract;
function WritePlataDescr(var pd; Ena:USHORT):ULONG; virtual; stdcall; abstract;
function ReadFlashWord(FlashAddress:USHORT; var Data:USHORT):ULONG; virtual; stdcall; abstract;
function WriteFlashWord(FlashAddress:USHORT; Data:USHORT):ULONG; virtual; stdcall; abstract;
function EnableFlashWrite(Flag:USHORT):ULONG; virtual; stdcall; abstract;
function EnableCorrection(Ena:USHORT):ULONG; virtual; stdcall; abstract;
function GetParameter(name:ULONG; var param:ULONG):ULONG; virtual; stdcall; abstract;
function SetParameter(name:ULONG; var param:ULONG):ULONG; virtual; stdcall; abstract;
function SetLDeviceEvent(hEvent:THandle; EventId:ULONG):ULONG; virtual; stdcall; abstract;
end;
Вот, как это выглядит в процедуре FormCreate программы:
- Код: Выделить всё
procedure TForm1.FormCreate(Sender: TObject);
begin
skip:=1;
Timer1.Enabled:=False;
Timer2.Enabled:=False;
LockXY:= TCriticalSection.Create;
Memo1.Lines.Clear;
Memo1.Lines.Add('Testing library');
if(CallCreateInstance('lcomp64.dll')=1) then
begin
Memo1.Lines.Add('Loading library - success.');
Memo1.Lines.Add('');
end;
{Укажите здесь виртуальный слот той платы с которой хотите работать}
pIUnknown:=CreateInstance(slot);
dec(PInteger(pIUnknown)^, sizeof(TVmt));
// Уменьшаем указатель на размер VMT
hr := pIUnknown.QueryInterface(IID_ILDEV,pLDev);
if(not Succeeded(hr)) then MessageBox(0,'Get interface failed','Error',MB_OK);
inc(PInteger(pIUnknown)^, sizeof(TVmt)); //Перед освобождением памяти
// возвращаем значение указателя
pIUnknown.Release;
dec(PInteger(pLDev)^, sizeof(TVmt)); // то же проделываем с указателем pLDev
dev:=pLDev.OpenLDevice;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
data:=NIL;
sync:=NIL;
Timer1.Enabled:=False;
Timer2.Enabled:=False;
pLDev.StopLDevice;
pLDev.CloseLDevice;
inc(PInteger(pLDev)^, sizeof(TVmt)); // возвращаем значение указателя pLDev
pLDev.Release;
LockXY.Free;
end;
Здесь мне пришлось уже несколько модифицировать эту процедуру в соответствии с рекомендациями, почерпнутыми из ссылки, упомянутой в начале (иначе получаю ошибку sigsegv), а именно я уменьшил указатели на точку входа pIUnknown и pLDev на размер VMT таблицы Lazarus'а (соответственно перед освобождением памяти вернул прежние значения этих указателей). В результате удалось загрузить оба этих класса, но при попытке использовать методы класса pLDev возникает ошибка:
- Код: Выделить всё
pLDev.GetSlotParam(sl); // здесь читает правильно
Memo1.Lines.Add('');
Memo1.Lines.Add('Slot parameters');
Memo1.Lines.Add('Base - '+IntToHex(sl.Base,4));
Memo1.Lines.Add('BaseL - '+IntToHex(sl.BaseL,4));
Memo1.Lines.Add('Mem - '+IntToHex(sl.Mem,8));
Memo1.Lines.Add('MemL - '+IntToHex(sl.MemL,8));
Memo1.Lines.Add('Type - '+IntToStr(sl.BoardType));
Memo1.Lines.Add('DSPType - '+IntToStr(sl.DSPType));
Memo1.Lines.Add('Irq - '+IntToStr(sl.Irq));
Memo1.Lines.Add('');
и далее:
- Код: Выделить всё
s:=IntToStr(pLDev.LoadBios('e440')); {no bios needed}
Memo1.Lines.Add('LoadBios status '+s);
s:=IntToStr(pLDev.ReadPlataDescr(pd)); // Ошибка !!!
Memo1.Lines.Add('ReadPlataDescr status '+s);
Memo1.Lines.Add('');
Memo1.Lines.Add('Serial Num. '+pd.t5.SerNum);
Memo1.Lines.Add('Board Name '+pd.t5.BrdName);
Memo1.Lines.Add('Revision '+pd.t5.Rev);
Memo1.Lines.Add('DSP Type '+pd.t5.DspType);
Memo1.Lines.Add('Quartz '+IntToStr(pd.t5.Quartz));
на первой картинке результат работы программы на Lazarus
[img]
лазерная эпиляция[img]
На второй Delphi
[img]
лазерная эпиляция[/img]
Судя по этим картинкам программа на Lazarus полностью отрабатывает процедуру pLDev.GetSlotParam(sl) правильно определяет тип платы (31 это код именно E14-140) и распределение памяти, но уже при попытке загрузить описание платы pLDev.ReadPlataDescr(pd) возникает ошибка.
Дополнения:
1. Хотя интерфейсный класс pIUnknown похож на соответствующий класс com интерфейса, но это не com интерфейс,
pLDev: IDaqLDevice;
pIUnknown:LUnknown;
2. sl:SLOT_PAR; определен в модуле ioctl, как
- Код: Выделить всё
SLOT_PAR = object
public
Base : ULONG;
BaseL : ULONG;
Base1 : ULONG;
BaseL1 : ULONG;
Mem : ULONG;
MemL : ULONG;
Mem1 : ULONG;
MemL1 : ULONG;
Irq : ULONG;
BoardType : ULONG;
DSPType : ULONG;
Dma : ULONG;
DmaDac : ULONG;
DTA_REG : ULONG;
IDMA_REG : ULONG;
CMD_REG : ULONG;
IRQ_RST : ULONG;
DTA_ARRAY : ULONG;
RDY_REG : ULONG;
CFG_REG : ULONG;
end;
PSLOT_PAR = ^SLOT_PAR;
pd: PLATA_DESCR_U2; определен в модуле ioctl, как
- Код: Выделить всё
PLATA_DESCR_U2 = record
case Integer of
0: (t1:PLATA_DESCR);
1: (t2:PLATA_DESCR_1450);
2: (t3:PLATA_DESCR_L791);
3: (wi:WORD_IMAGE_256);
4: (bi:BYTE_IMAGE_256);
5: (t4:PLATA_DESCR_E440);
6: (t5:PLATA_DESCR_E140);
7: (t6:PLATA_DESCR_E2010);
8: (t7:PLATA_DESCR_E154);
end;
соответственно PLATA_DESCR_E140 определяется, как:
- Код: Выделить всё
PLATA_DESCR_E140 = object
public
SerNum : array [0..8] of CHAR;
BrdName : array [0..10] of CHAR;
Rev : CHAR;
DspType : array [0..10] of CHAR;
IsDacPresent : CHAR;
Quartz : ULONG;
Reserv2 : array [0..2] of UCHAR;
KoefADC : array [0..7] of single;
KoefDAC : array [0..3] of single;
Custom : array [0..19] of USHORT;
end;
PPLATA_DESCR_E140 = ^PLATA_DESCR_E140;
Я понимаю, что, возможно изменения указателей на точку входа класса еще недостаточно и надо бы как то модифицировать VMT таблицу класса, но знаний не хватает, поэтому прошу Вашего (или ваших) советов. Конечно, можно было бы просто плюнуть на всё и продолжить работать в Delphi, но уж очень обидно, тем более, что Lazarus объективно лучше.
