library calldll; {32-bit-Version!}
{$HINTS ON}
{$Z4}
{$D Matlab-MEX: Universal-DLL-Aufrufschnittstelle (h#s 03/01)}
uses PasMex32,Windows;
{Schlafmützen, die die Delphi-Standardbibliothek geschrieben haben:}
function wsprintf1(ret,template,a1: PChar):LongInt;
cdecl; external 'user32.dll' name 'wsprintfA';
function wsprintf2(ret,template,a1,a2: PChar):LongInt;
cdecl; external 'user32.dll' name 'wsprintfA';
var
hDllLast: THandle; {geladene DLL}
ParseStr: array[0..1023] of Char;
ProcEntry: TFarProc;
cdecl: Boolean; {sonst stdcall!}
type
PAnyNum=^TAnyNum;
TAnyNum=record
case integer of
1: (x: double);
2: (s: single);
3: (l: LongInt);
4: (w: Word);
5: (i: SmallInt);
6: (c: Char);
7: (b: Byte);
8: (h: ShortInt);
end;
const
ARG_I08 =$81;
ARG_I16 =$82; {Standard für mxIsNumeric}
ARG_I32 =$84;
ARG_U08 =$01;
ARG_U16 =$02;
ARG_U32 =$04;
ARG_F32 =$C4;
ARG_F64 =$C8;
ARG_C08 =$01; {Standard für mxIsString}
ARG_Str =$00;
ARG_Ptr =$20; {falls m*n<>1}
ARG_Ret =$10;
{Bit
7=vzb/vzl
6=Gleitkomma/Ganzzahl
5=Pointer auf Datentyp (Indirektion, immer FAR)
4=Parameter-Rückgabe (schließt Bit 5 ein)
3..0=Zahl der Bytes pro Element}
var
argt: array[0..17] of Byte;
{Index 0: Funktionsergebnis, 1..17: Argumente}
allocs: array[0..17] of PAnyNum;
sizes: array[0..17] of LongInt;
type
TType=record
t: Byte;
c: Char;
s: array[0..3] of Char;
end;
const
CType: array[0..8] of TType=(
(t: ARG_I08; c: 'h'; s: 'i08'),
(t: ARG_I16; c: 'i'; s: 'i16'),
(t: ARG_I32; c: 'l'; s: 'i32'),
(t: ARG_U08; c: 'c'; s: 'u08'),
(t: ARG_U16; c: 'u'; s: 'u16'),
(t: ARG_U32; c: 'w'; s: 'u32'),
(t: ARG_F32; c: 'f'; s: 'f32'),
(t: ARG_F64; c: 'g'; s: 'f64'),
(t: ARG_Str; c: 's'; s: 'str')); {nullterminierter String}
function mxGetMxN(pm: PArray):LongInt;
begin
mxGetMxN:=mxGetM(pm)*mxGetN(pm);
end;
function lstrchr(s:PChar; c:Char):PChar;
begin
lstrchr:=nil;
while s^<>#0 do begin
if s^=c then begin
lstrchr:=s;
exit;
end;
s:=AnsiNext(s);
end;
end;
procedure ParseArg(Arg:PChar; ArgNum: Integer);
{Einen einzelnen Argument-Prototypen erfassen}
(* Syntaxdiagramm: {*}spec{[{arraysize}]} *)
var
sp,sp2: PChar;
i,e: Integer;
begin
while Arg^=' ' do Inc(Arg); {TrimLeft}
if Arg^='*' then begin
Inc(Arg);
argt[ArgNum]:=argt[ArgNum] or ARG_Ptr {Indirektion}
end;
sp:=lstrchr(Arg,'[');
if sp<>nil then begin
sp^:=#0;
inc(sp);
argt[ArgNum]:=argt[ArgNum] or (ARG_Ptr or ARG_Ret); {Indirektion und Ret}
sp2:=lstrchr(sp,']');
if sp2=nil then mexErrMsgTxt('Prototyp-[]');
sp2^:=#0;
if sp2<>sp then begin {sonst Länge von Matrix nehmen}
Val(sp,sizes[ArgNum],e);
if e<>0 then mexErrMsgTxt('Prototyp-Arraygr÷▀e');
end;
end;
for i:=0 to 8 do with CType[i] do begin
if (Arg[0]=c) and (Arg[1]=#0)
or (lstrcmpi(Arg,s)=0) then begin
argt[ArgNum]:=argt[ArgNum] and (ARG_Ptr or ARG_Ret) or t;
exit;
end;
end;
mexErrMsgTxt('Prototyp-Typ');
end;
function IsBadHandle(h:THandle):Boolean;
begin
IsBadHandle:=(h>=0) and (h<=32);
end;
procedure ParseString;
var
hDLL: THandle;
sp,sp2: PChar;
wordval: Word;
arg,e: Integer;
s,sDLL: array[byte] of Char; {zu ladende DLL}
OldEM: Word;
begin
sp:=lStrChr(ParseStr+2,':'); {<Laufwerk:> übergehend}
if sp<>nil then begin {Versuch, die DLL zu laden}
lstrcpyn(sDLL,ParseStr,sp-ParseStr+1);
sp2:=sDLL+lstrlen(sDLL); {End-Position}
OldEM:=SetErrorMode(SEM_NoOpenFileErrorBox);
hDLL:=LoadLibrary(sDLL);
if IsBadHandle(hDLL) then begin
lstrcpy(sp2,'.DLL'); {heranflicken (1. Versuch)}
hDLL:=LoadLibrary(sDLL);
if IsBadHandle(hDLL) then begin
lstrcpy(sp2,'32.DLL'); {heranflicken (2. Versuch)}
hDLL:=LoadLibrary(sDLL);
end;
end;
SetErrorMode(OldEM);
if not IsBadHandle(hDLL) then begin
FreeLibrary(hDllLast);
hDllLast:=hDLL;
end else begin
wsprintf2(s,'Kann DLL "%s" nicht finden/laden, Code=%d',sDLL,PChar(hDLL));
mexErrMsgTxt(s);
end;
inc(sp);
end else sp:=ParseStr;
sp2:=lstrchr(sp,' ');
if sp2<>nil then sp2^:=#0;
cdecl:=false;
Val(sp,wordval,e); {numerischer Einsprung?}
if e=0 then sp:=MakeIntResource(wordval)
else if sp^='_' then cdecl:=true;
ProcEntry:=GetProcAddress(hDllLast,sp);
if (ProcEntry=nil) and (LongRec(LongInt(sp)).hi<>0) then begin
lstrcpy(sDLL,sp);
lstrcat(sDLL,'A'); {ASCII-Version probieren (wird gern vergessen)}
ProcEntry:=GetProcAddress(hDllLast,sDLL);
end;
if ProcEntry=nil then begin
if LongRec(LongInt(sp)).hi=0 then begin
wsprintf1(s,'Kann Einsprungpunkt #%d nicht finden',sp);
end else begin
wsprintf1(s,'Kann Einsprungpunkt "%s" nicht finden',sp);
end;
mexErrMsgTxt(s);
end;
arg:=1;
while sp2<>nil do begin
sp:=sp2+1;
if sp^=#0 then break; {Nichts mehr zu parsen}
sp2:=lstrchr(sp,'=');
if sp2<>nil then arg:=0 {Retval-Argument}
else sp2:=lstrchr(sp,',');
if sp2<>nil then sp2^:=#0;
ParseArg(sp,arg);
Inc(arg);
end;
end;
procedure ShowProto(hirhs:Integer);
var
sp: PChar;
carg: Byte;
c: Char;
i,j: Integer;
s: array[0..255] of Char;
begin
sp:=s;
for i:=0 to hirhs do begin
carg:=argt[i] and not (ARG_Ptr or ARG_Ret);
for j:=0 to 8 do if carg=CType[j].t then break;
lstrcpy(sp,CType[j].s); Inc(sp,3);
if argt[i] and ARG_Ptr <>0
then Inc(sp,wsprintf1(sp,'[%d]',PChar(sizes[i])));
if argt[i] and ARG_Ret <>0
then begin sp^:='r'; inc(sp); end;
c:=',';
if i=hirhs then c:=#0;
if i=0 then c:='=';
sp^:=c; inc(sp);
end;
sp^:=#0;
sp:=s;
mexPrintf1('%s'#10,LongInt(sp));
end;
function CallEntry(hirhs:Integer; var prhs:TMatArr):Double; stdcall;
const
StackFehler: array[0..11] of Char='Stackfehler';
var
i: integer;
xx: TAnyNum;
xp,xp2: PAnyNum;
rp: PDouble;
l: LongInt;
carg: Byte;
cmat: PArray;
csiz: LongInt;
{$IFOPT D+}
s: array[0..15] of Char;
{$ENDIF}
savestack,teststack: Cardinal;
begin
asm mov [savestack],esp; mov [teststack],esp end;
for i:=hirhs downto 1 do begin {cdecl und stdcall: umgek. Reihenfolge!}
carg:=argt[i];
cmat:=prhs[i];
csiz:=sizes[i];
if carg and Arg_Ptr <>0 then begin
carg:=carg and not (ARG_Ptr or ARG_Ret);
if carg=ARG_Str then begin
xp:=PAnyNum(LocalAlloc(LMEM_Fixed,csiz+1));
if xp=nil then mexErrMsgTxt('Speicherfehler');
allocs[i]:=xp;
mxGetString(cmat,PChar(xp),csiz+1);
end else if (carg=ARG_F64)
and (mxGetMxN(cmat)=csiz)
then PDouble(xp):=mxGetPr(cmat) {nicht ganzes Array kopieren}
else begin
xp:=PAnyNum(LocalAlloc(GMEM_Fixed,csiz*(carg and $0F)));
if xp=nil then mexErrMsgTxt('Speicherfehler');
allocs[i]:=xp;
rp:=mxGetPr(cmat);
l:=mxGetMxN(cmat);
xp2:=xp;
if l>csiz then l:=csiz;
repeat {compiliert besser als FOR}
with xp2^ do case carg of
ARG_I08: h:=Round(rp^);
ARG_I16: i:=Round(rp^);
ARG_I32,
ARG_U32: l:=Round(rp^);
ARG_U16: w:=Round(rp^);
ARG_U08: b:=Round(rp^);
ARG_F32: s:=rp^;
ARG_F64: x:=rp^;
end;
Inc(rp);
Inc(PChar(xp2),carg and $0F);
Dec(l);
until l=0;
end{case};
asm push [xp] end;
end else begin
xx.x:=mxGetScalar(cmat);
case carg of
ARG_F64: ;
ARG_F32: xx.s:=xx.x;
else xx.l:=Round(xx.x);
{Alle integralen Typen in INTEL-Notation: reicht!}
end;
asm mov al,[carg]
and al,0Fh
cmp al,8 {DOUBLEs?}
jc @@1
push dword ptr [xx+4]
@@1: {alles andere sind LONGINTs, hier ganz einfach!}
push dword ptr [xx]
end;
end{if};
end{for};
asm cmp [cdecl],FALSE
jz @@pas
mov [teststack],esp {bei cdecl ist dies die Stack-Rückgabepos.}
@@pas: call [ProcEntry] {Aufruf!}
mov [xx.l],eax
cmp [teststack],esp {steht richtig?}
je @@1
push offset stackfehler
call mexWarnMsgTxt {ob dieser ST(0) in Ruhe läßt?}
pop cx {Matlab-Funktionen sind cdecl!}
@@1: mov esp,[savestack]
mov al,byte ptr argt
cmp al,ARG_F64
jz @@sto
cmp al,ARG_F32
jz @@sto
cmp al,ARG_I16
jz @@i16
cmp al,ARG_I32
jz @@i32
cmp al,ARG_U32
jz @@i32
cmp al,ARG_U16
jz @@u16
cmp al,ARG_U08
jz @@u08
cmp al,ARG_I08
jz @@i08
jmp @@e
@@i08: mov al,[xx.h]
cbw
mov [xx.i],ax
jmp @@i16
@@u08: mov byte ptr xx[1],0
@@i16: fild [xx.i]
jmp @@sto
@@u16: mov word ptr xx[2],0
@@i32: fild [xx.l]
jmp @@sto
@@sto: fwait
fstp [@result]
fwait
@@e:
end;
for i:=1 to hirhs do begin
carg:=argt[i];
cmat:=prhs[i];
csiz:=sizes[i];
if carg and ARG_Ret <>0 then begin
carg:=carg and not (ARG_Ptr or ARG_Ret);
if carg=ARG_Str then begin
mexWarnMsgTxt('String-Rⁿckgabe fⁿhrt zu InstabilitΣt in Matlab');
mxDestroyArray(cmat);
cmat:=mxCreateString(PChar(allocs[i])); {Ende an terminierender Null}
{ MessageBox(hwndMatlabCmd,Ptr(allocs[i],0),'Hier vorbei',0);}
{MATLAB scheint Schwierigkeiten zu haben, Return-Werte auf der rechten
Seite (als quasi VAR-Parameter) zu liefern!}
prhs[i]:=cmat;
end else begin
if mxGetMxN(cmat)<>csiz then begin
mexWarnMsgTxt('Die rechtsseitige Ergebnismatrix sollte gleich gro▀ sein!'#10+
'Matlab wird instabil');
mxDestroyArray(cmat);
cmat:=mxCreateDoubleMatrix(1,csiz,mxREAL);
prhs[i]:=cmat; {ob sie jemals da ankommt? Manchmal!}
end else if carg=ARG_F64 then continue; {nächstes I}
rp:=mxGetPr(cmat);
xp:=allocs[i];
l:=csiz;
repeat {compiliert besser als FOR}
with xp^ do case carg of
ARG_I08: xx.x:=h;
ARG_I16: xx.x:=i;
ARG_I32,
ARG_U32: xx.x:=l;
ARG_U16: xx.x:=w;
ARG_U08: xx.x:=b;
ARG_F32: xx.x:=s;
ARG_F64: xx.x:=x;
end;
rp^:=xx.x;
{$IFOPT D+}
str(rp^:3:3,s);
lstrcat(s,#10);
mexPrintf0(s);
{$ENDIF}
Inc(rp);
Inc(PChar(xp),carg and $0F);
Dec(l);
until l=0;
end;
end{if};
end{for};
end;
function R2I(pm: PArray; min,max: Integer; var r: array of Integer):Boolean;
var
zp: PDouble;
i,e: Integer;
begin
R2I:=false;
if not mxIsNumeric(pm) then exit;
zp:=mxGetPr(pm);
e:=mxGetM(pm);
if e>HIGH(r) then e:=HIGH(r);
for i:=0 to e do begin
if (zp^<min) or (zp^>max) then exit;
r[i]:=Round(zp^);
Inc(zp);
end;
R2I:=true;
end;
procedure mexFunction(nlhs:Integer; var plhs:TMatArr;
nrhs:Integer; var prhs:TMatArr); stdcall;
var
i: Integer;
t: Byte;
pm: ^PArray;
x: Double;
{ intp: PInteger;
s: array[0..255] of Char;}
begin
FillChar(allocs,sizeof(allocs),0);
{if Catch(CatchBuf)=0 then} begin
if nrhs>=1 then begin
FillChar(argt,sizeof(argt),0);
mxGetString(prhs[0],ParseStr,sizeof(ParseStr)-1);
if nlhs<>0 then argt[0]:=ARG_I16;
pm:=@prhs[0];
for i:=1 to nrhs-1 do begin
Inc(pm);
if mxIsChar(pm^) then t:=ARG_Str or ARG_Ptr
else t:=ARG_I16;
sizes[i]:=mxGetMxN(pm^);
if sizes[i]>1 then t:=t or ARG_Ptr;
argt[i]:=t;
end;
ParseString;
{$IFOPT D+}
ShowProto(nrhs-1);
{$ENDIF}
x:=CallEntry(nrhs-1,prhs);
if argt[0]<>0 then begin
plhs[0]:=mxCreateDoubleMatrix(1,1,mxREAL);
mxGetPr(plhs[0])^:=x;
end;
end else mexPrintf0(
'1 und mehr Parameter:'#10+
'1. ''[DLL-Name:]Eintrittspunkt[ Prototyp]'' (wird DLL-Name weggelassen, dann letztgenutzte)'#10+
' Funktionsprototyp ''i=i,u32,f,s,i16,i32'' i=int, u=unsigned, f=float, s=asciiz'#10+
'2.. Parameter'#10+
'Mehr Info: help calldll'#10);
end;
for i:=0 to 17 do if allocs[i]<>nil then LocalFree(Integer(allocs[i]));
end;
exports
mexFunction;
var
OldExitProc: Pointer;
procedure NewExitProc;
begin
ExitProc:=OldExitProc;
FreeLibrary(hDllLast);
end;
begin
DisableThreadLibraryCalls(HInstance);
OldExitProc:=ExitProc;
ExitProc:=@NewExitProc;
hDllLast:=LoadLibrary('user32.dll');
end.
| Detected encoding: OEM (CP437) | 1
|
|
|