library calldll; {$N+,E-} {MATLAB setzt ohnehin Koprozessor voraus}
{$D Matlab-MEX: Universal-DLL-Aufrufschnittstelle (h#s 12/99)}
uses pasmex,winprocs,wintypes,win31,wutils;
var
CatchBuf: TCatchBuf;
hDllLast: THandle;
ParseStr: array[0..1023] of Char;
ProcEntry: TFarProc;
cdecl: Boolean;
procedure Error(s: PChar);
begin
mexVPrintf('CALLDLL.DLL: FEHLER: %s'#10,s,4);
Throw(CatchBuf,-1);
end;
procedure Warning(s: PChar);
begin
mexVPrintf('CALLDLL.DLL: WARNUNG: %s'#10,s,4);
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 THandle;
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: PMatrix):LongInt;
begin
mxGetMxN:=mxGetM(pm)*mxGetN(pm);
end;
procedure ParseArg(Arg:PChar; ArgNum: Integer);
{Einen einzelnen Argument-Prototypen erfassen}
(* Syntaxdiagramm: {*}spec{[{arraysize}]} *)
var
sp,sp2: PChar;
i,e: Integer;
b: Byte;
begin
while Arg^=' ' do Inc(Arg); {TrimLeft}
if Arg^='*' then begin
Inc(Arg);
asm mov si,[ArgNum]
or byte ptr argt[si],ARG_Ptr {Indirektion}
end;
end;
sp:=lstrchr(Arg,'[');
if sp<>nil then begin
sp^:=#0;
inc(sp);
asm mov si,[ArgNum]
or byte ptr argt[si],(ARG_Ptr or ARG_Ret) {Indirektion und Ret}
end;
sp2:=lstrchr(sp,']');
if sp2=nil then Error('Prototyp-[]');
sp2^:=#0;
if sp2<>sp then begin {sonst Länge von Matrix nehmen}
Val(sp,sizes[ArgNum],e);
if e<>0 then Error('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
b:=t;
asm mov si,[ArgNum]
and byte ptr argt[si],ARG_Ptr or ARG_Ret
mov al,[b]
or byte ptr argt[si],al
end;
exit;
end;
end;
Error('Prototyp-Typ');
end;
procedure ParseString;
var
hDLL: THandle;
sp,sp2: PChar;
wordval: Word;
arg,e: Integer;
savebuf: array[0..4] of Char;
OldEM: Word;
begin
sp:=lStrChr(ParseStr,':');
if sp=ParseStr+1
then sp:=lStrChr(ParseStr+2,':'); {<Laufwerk:> übergehend}
if sp<>nil then begin {Versuch, die DLL zu laden}
OldEM:=SetErrorMode(SEM_NoOpenFileErrorBox);
sp^:=#0;
hDLL:=LoadLibrary(ParseStr);
if hDLL<32 then begin
Move(sp^,savebuf,5); {ausstanzen}
lstrcpy(sp,'.DLL'); {heranflicken}
hDLL:=LoadLibrary(ParseStr);
Move(savebuf,sp^,5); {zurücksetzen}
end;
SetErrorMode(OldEM);
if hDLL>=32 then begin
FreeLibrary(hDllLast);
hDllLast:=hDLL;
end else Error('Kann DLL nicht finden/laden');
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 then Error('Kann Einsprungpunkt nicht finden');
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,wvsprintf(sp,'[%ld]',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;
mexVPrintf('%s'#10,sp,4);
end;
type
PAnyNum=^TAnyNum;
TAnyNum=record
case integer of
1: (x: double);
2: (s: single);
3: (l: LongInt);
4: (w: Word);
5: (i: Integer);
6: (c: Char);
7: (b: Byte);
8: (h: ShortInt);
end;
function CallEntry(hirhs:Integer; var prhs:TMatArr):Double;
const
StackFehler: array[0..11] of Char='Stackfehler';
var
i: integer;
xx: TAnyNum;
xp,xp2: PAnyNum;
rp: HPDouble;
l: LongInt;
carg: Byte;
cmat: PMatrix;
csiz: LongInt;
s: array[0..15] of Char;
savestack,teststack: Word;
begin
asm mov [savestack],sp; mov [teststack],sp end;
for i:=1 to hirhs do begin
carg:=argt[i];
cmat:=prhs[i];
csiz:=sizes[i];
if carg and Arg_Ptr <>0 then begin
asm and carg,not (ARG_Ptr or ARG_Ret) end;
if carg=ARG_Str then begin
xp:=Ptr(GlobalAlloc(GMEM_Fixed,csiz+1),0);
if PtrRec(xp).sel=0 then Error('Speicherfehler');
allocs[i]:=PtrRec(xp).sel;
mxGetString(cmat,PChar(xp),csiz+1);
end else if (carg=ARG_F64)
and (mxGetMxN(cmat)=csiz)
then HPDouble(xp):=mxGetPr(cmat) {nicht ganzes Array kopieren}
else begin
xp:=Ptr(GlobalAlloc(GMEM_Fixed,csiz*(carg and $0F)),0);
if PtrRec(xp).sel=0 then Error('Speicherfehler');
allocs[i]:=PtrRec(xp).sel;
rp:=mxGetPr(cmat);
l:=mxGetMxN(cmat);
asm db $66; mov ax,word ptr [xp];
db $66; mov word ptr [xp2],ax;
db $66; mov ax,word ptr [csiz];
db $66; cmp ax,word ptr [l]
jnc @@1
db $66; mov word ptr [l],ax; {Minimum zu l}
@@1:
end;
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;
IncHP(PChar(rp),8);
IncHP(PChar(xp2),carg and $0F);
asm db $66; dec word ptr[l] end;
until l=0;
end{case};
asm db $66; push word ptr [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);{Integrale Typen in INTEL-Notation: reicht!}
end;
asm mov al,[carg]
and al,0Fh
cmp al,8 {DOUBLEs?}
jc @@1
db $66; push word ptr [xx+4]
@@1: cmp al,4 {LONGINTs?}
jc @@2
push word ptr [xx+2]
@@2: push word ptr [xx+0]
end;
end{if};
end{for};
asm cmp [cdecl],FALSE
jz @@pas
mov [teststack],sp {bei cdecl ist dies die Stack-Rückgabepos.}
@@pas: call [ProcEntry] {Aufruf!}
mov [xx.i],ax
mov word ptr xx[2],dx {LongInt-Rückgabe retten}
cmp [teststack],sp {steht richtig?}
je @@1
push ds
push offset stackfehler
call Warning {ob dieser ST(0) in Ruhe läßt?}
@@1: mov sp,[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
asm and carg,not (ARG_Ptr or ARG_Ret) end;
if carg=ARG_Str then begin
Warning('String-Rⁿckgabe fⁿhrt zu InstabilitΣt in Matlab');
mxFreeMatrix(cmat);
cmat:=mxCreateString(Ptr(allocs[i],0)); {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
Warning('Die rechtsseitige Ergebnismatrix sollte gleich gro▀ sein!'#10+
'Matlab wird instabil');
mxFreeMatrix(cmat);
cmat:=mxCreateFull(1,csiz,false);
prhs[i]:=cmat; {ob sie jemals da ankommt? Manchmal!}
end else if carg=ARG_F64 then continue; {nächstes I}
rp:=mxGetPr(cmat);
xp:=Ptr(allocs[i],0);
asm db $66; mov ax,word ptr [csiz];
db $66; mov word ptr [l],ax;
end;
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);
mexVPrintf(s,s,0);
{$ENDIF}
IncHP(PChar(rp),8);
IncHP(PChar(xp),carg and $0F);
asm db $66; dec word ptr[l] end;
until l=0;
end;
end{if};
end{for};
end;
function R2I(pm: PMatrix; min,max: Integer; var r: array of Integer):Boolean;
var
zp: HPDouble;
i,e: Integer;
begin
R2I:=false;
if not mxIsNumeric(pm) then exit;
zp:=mxGetPr(pm);
e:=wutils.min(HIGH(r),mxGetM(pm));
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); export;
var
i: Integer;
t: Byte;
pm: ^PMatrix;
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 mxIsString(pm^) then t:=ARG_Str or ARG_Ptr
else t:=ARG_I16;
sizes[i]:=mxGetMxN(pm^);
if sizes[i]>1 then asm or t,ARG_Ptr end;
argt[i]:=t;
end;
ParseString;
{$IFOPT D+}
ShowProto(nrhs-1);
{$ENDIF}
x:=CallEntry(nrhs-1,prhs);
if argt[0]<>0 then begin
plhs[0]:=mxCreateFull(1,1,false);
mxGetPr(plhs[0])^:=x;
end;
end else mexVPrintf(
'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',i,0);
end;
for i:=0 to 17 do if allocs[i]<>0 then GlobalFree(allocs[i]);
end;
exports
set_entry_point index 2,
mexFunction index 3,
mexAtExitFcn index 4;
var
OldExitProc: Pointer;
procedure NewExitProc; far;
begin
ExitProc:=OldExitProc;
FreeLibrary(hDllLast);
end;
begin
OldExitProc:=ExitProc;
ExitProc:=@NewExitProc;
hDllLast:=LoadLibrary('USER');
end.
| Detected encoding: OEM (CP437) | 1
|
|
|