library GPIB;
{$C MOVEABLE PRELOAD PERMANENT}
{Bibliothek zur Ansteuerung der HAMEG-GPIB-Karte HO-80,
Einsprungpunkte kompatibel zur GPIB.DLL von National Instruments.
Zur Konfiguration wird dieselbe GPIB.INI verwendet}
uses WinProcs, WinTypes;
{$D HAMEG HO-80 GPIB Windows driver h#s}
{Die HAMEG-Karte hat ein 8K-EPROM mit diversen Einsprungpunkten.
Dieser EPROM kann per DIP-Schalter auf durch 2000h teilbare Basisadressen
gelegt werden; die Initialisierungsroutine sucht die momentane Adresse.
Falls nicht gefunden, gibt's eine Fehlermeldung.
Das Programm im EPROM ist nicht protected-mode-lauffähig, sodaß mittels
DPMI-Funktionen Translationen gemacht werden müssen.
}
{Aufgrund der gänzlich anderen Funktionalität der HAMEG-Software wird nur
ein sehr kleiner Teil der NI-DLL nachgebildet; die anderen Funktionen
werden hier im Labor sehr selten angewendet. Die maximale Puffergröße
ist 8K.
h#s, 19.02.99}
const
MAXBUF=$2000; {Maximale Puffergröße zum Schaufeln: 8K}
MAGICBASE=1000; {Gültige Deskriptoren zwischen 1000 und 1031}
PROFILE='GPIB.INI'; {Hierher werden die Daten bezogen...}
MAXDEBUGOUT=128; {Maximale Länge für angezeigten Debugstring}
type
LongRec=record
lo,hi: Word;
end;
WordRec=record
lo,hi: Byte;
end;
PtrRec=record
ofs,sel: Word;
end;
TRealModeCall=record {Format of DPMI real mode call structure}
case integer of
4:(_EDI, _ESI, _EBP, r0, _EBX, _EDX, _ECX, _EAX: LongInt);
2:(_DI,r1,_SI,r2,_BP,r3,r4,r5,_BX,r6,_DX,r7,_CX,r8,_AX,r9,
flags,_ES,_DS,_FS,_GS,_IP,_CS,_SP,_SS: Word);
end;
PMemoryImage=^TMemoryImage;
TMemoryImage=record {Format des Speichers von GlobalDosAlloc}
stack: array[0..63] of Word;
args: array[0..3] of LongRec;
buffer: array[0..MAXBUF-1] of Char;
end;
P_NI_Stapel=^T_NI_Stapel; {die letzten 3 Argumente sind immer gleich}
T_NI_Stapel=record
cntl: PLongInt;
err: PInteger;
sta: PInteger;
end;
var
RMC: TRealModeCall; {Struktur zum Aufruf der Real-Mode-Routine}
MemImg: PMemoryImage; {zeigt auf den angeforderten Speicher}
Mem: record {der Rückgabewert bei GlobalDosAlloc}
Sel: Word; {Selektor (PM) des Transferpuffers}
Seg: Word; {Segment (RM) des Transferpuffers}
end;
RomSeg: Word; {Gefundene ROM-Basisadresse}
Status: Word; {Status-Wort der Hameg-Funktionen}
const {Status-Wort-Bits (alles Fehler?)}
HS_UnknownCommand =1;
HS_ReceiverUnknown =2;
HS_EndCommand =4;
HS_Timeout =8;
HS_InvalCommandOrder =16;
HS_EOIReceived =32;
var
libsta: Integer;
liberr: Integer;
libcnt: Integer;
eos: array[MAGICBASE..MAGICBASE+31] of Integer;
const {Bitmasken für eos[]}
NI_EOS=$FF;
NI_REOS=$400;
NI_XEOS=$800;
NI_8BIT=$1000;
NI_ALL=NI_8BIT or NI_XEOS or NI_REOS or NI_EOS;
NI_EOT=$4000;
{$IFOPT D+}
var
DebugStr: array[0..1023] of Char;
const
PutMsg: boolean=true;
function IsInvisible(c:Char):Boolean;
{liefert TRUE, wenn Zeichen im üblichen Windows-Zeichensatz nicht sichtbar}
begin
IsInvisible:=(c<' ') or (c>=#$80) and (c<#$A0);
end;
function EscapeStr(s: PChar; slen: Integer): PChar;
{Wandelt übergebenen String (nicht nullterminiert) in C-String
mit Escape-Sequenzen um, auch \" und \' und \\.
Die Maximallänge des Ergebnisses ist 100 Zeichen plus Ellipse.}
const
s1: array[0..105] of Char='';
var
su: Char;
sp: PChar;
begin
sp:=s1;
for slen:=slen downto 1 do begin
su:=#0;
case s^ of
'\','"','''': su:=s^;
#7: su:='a';
#8: su:='b';
#9: su:='t';
#10: su:='n';
#13: su:='r';
end;
if su<>#0 then sp:=sp+wvsprintf(sp,'\%c',su)
else begin
su:=s^;
if IsInvisible(su) then sp:=sp+wvsprintf(sp,'\x%02X',su)
else begin
sp^:=su;
Inc(sp);
end;
end;
if sp-s1>100 then break;
Inc(s);
end{for};
if slen>1 then lstrcpy(sp,'...')
else sp^:=#0;
EscapeStr:=s1;
end;
{$ENDIF}
{Offsets sind Alias-Deskriptoren der entsprechenden Real-Mode-Segmente}
procedure __C000h; far; external 'KERNEL' index 195;
procedure __D000h; far; external 'KERNEL' index 179;
procedure __E000h; far; external 'KERNEL' index 190;
function scanseg(Sel,Seg:Word):Boolean;
{sucht ein 64K-Segment nach der Karte ab und liefert TRUE wenn gefunden.
RomSeg wird aus übergebenem Seg und dem Offset berechnet.}
var
p: PChar;
begin
scanseg:=false;
p:=Ptr(Sel,0);
repeat
if (p[53]='*') and (p[54]='*') and (lstrcmp(p+48,'HO80')=0) then begin
scanseg:=true; {gefunden}
RomSeg:=Seg+PtrRec(p).ofs shr 4; {Ermitteln von RomSeg}
exit; {fertig}
end;
Inc(p,$2000);
until PtrRec(p).Ofs=0; {bis 64K um (Offsetüberlauf)}
end;
function CallRom(Einsprung: Word):Boolean;
begin
with RMC,MemImg^ do begin
stack[63]:=sizeof(stack)+12; {4 NEAR-Zeiger auf DWORD-Argumente}
stack[62]:=sizeof(stack)+8;
stack[61]:=sizeof(stack)+4;
stack[60]:=sizeof(stack);
_SP:=60*2; {Flags werden einmal bei CheckBoard gesetzt}
_SS:=Mem.seg; _DS:=Mem.seg; _ES:=Mem.seg;
_CS:=RomSeg; _IP:=Einsprung;
asm xor bx,bx
xor cx,cx
push ds
pop es
mov di,offset RMC
mov ax,301h
int 31h {Call Real Mode Procedure with FAR return}
cmc
mov al,0
adc al,al
mov [@result],al
end;
end;
end;
function CheckBoard: boolean;
const
Checked: Boolean=false; {es wird nur einmal getestet}
{$IFOPT D+}
MBoxTitle='HAMEG GPIB.DLL(Debug) Fehler';
{$ELSE}
MBoxTitle='HAMEG GPIB.DLL Fehler';
{$ENDIF}
begin
liberr:=0;
libsta:=0;
libcnt:=0;
Status:=0;
if not Checked then begin
if scanseg(Ofs(__C000h),$C000) {eine Hercules-Karte hat keinen ROM}
or scanseg(Ofs(__D000h),$D000) {gewöhnlicher UMB}
or scanseg(Ofs(__E000h),$E000) then begin
LongInt(Mem):=GlobalDosAlloc(sizeof(TMemoryImage));
if Mem.Sel<>0 then begin
MemImg:=GlobalLock(Mem.Sel);
FillChar(MemImg^,sizeof(TMemoryImage),0);
FillChar(RMC,sizeof(RMC),0);
RMC.flags:=$3202; {STI - sonst steht der Mauszeiger!}
MemImg^.Args[1].Lo:=GetPrivateProfileInt('GPIB0','Pad',0,PROFILE);
{my_address, in den Labors: 0}
if not CallRom(0) then begin
MessageBox(0,'DPMI-Aufruf des Karten-ROMs versagt.',MBoxTitle,
MB_TaskModal or MB_IconStop or MB_OK);
end;
end else begin
MessageBox(0,'DOS-Speicheranforderung versagt.',MBoxTitle,
MB_TaskModal or MB_IconStop or MB_OK);
end;
end else begin
MessageBox(0,'Die HAMEG HO80 GPIB-Karte wurde nicht gefunden!'#10+
'Falls sie steckt, k÷nnte sie durch EMM386.EXE verdeckt worden sein.'#10+
'Falls eine National Instruments Karte steckt, mu▀ die GPIB.DLL '+
'von National Instruments verwendet werden.',MBoxTitle,
MB_TaskModal or MB_IconStop or MB_OK);
end;
Checked:=true;
end;
if RomSeg=0 then liberr:=7;
CheckBoard:=(RomSeg<>0) and (Mem.Sel<>0);
end;
function CheckUD(ud: Integer): Boolean;
{Überprüft das Board und den Deskriptor}
begin
Dec(ud,MAGICBASE);
CheckUD:=CheckBoard and (Word(ud)<=30);
end;
{$IFOPT D+}
function DebugEnd: PChar;
begin
DebugEnd:=DebugStr+lstrlen(DebugStr);
end;
{$ENDIF}
function iwsd(str: PChar; i: Integer):Boolean;
{Ruft die ROM-Funktion iwsd (interface write secondary data) auf}
begin
{$IFOPT D+}
wvsprintf(DebugEnd,#10'iwsd >%s<',str);
{$ENDIF}
with MemImg^ do begin
args[0].lo:=Status;
args[1].lo:=wvsprintf(buffer,str,i);
args[1].hi:=sizeof(stack)+sizeof(args);
CallRom(30);
Status:=args[0].lo;
end;
end;
procedure ReprogPorts(ud: Integer);
begin
Port[$2B8+7]:=WordRec(eos[ud]).lo; {End Of String Register}
Port[$2B8+5]:=WordRec(eos[ud]).hi and $1C or $80; {Auxiliary A Register}
end;
{*** NI-GPIB.DLL-Funktionsnachbildungen ***}
function MakeResult:Integer;
{wandelt die Hameg-Funktionsergebnisse in NI-Ergebnisse um.
Darf nur aus einer der DLLibxxx-Routinen gerufen werden,
damit der Stack-Frame stimmt, um die 3 langweiligen VAR-Parameter
ibcntl, iberr und ibsta zu setzen}
var
Stapel: P_NI_Stapel;
begin
{$IFOPT D+}
wvsprintf(DebugEnd,#10'Status=%X',Status);
if PutMsg and (MessageBox(0,DebugStr,'GPIB.DLL DebugMsg',
MB_TaskModal or MB_OKCancel)=IDCancel) then PutMsg:=false;
{$ENDIF}
(* if Status and HS_Timeout <>0 then begin
liberr:=6; {Timeout-Code für NI}
libsta:=libsta or $4000;
end;*)
if Status and HS_ReceiverUnknown <>0 then liberr:=2;
if Status and HS_EOIReceived <>0 then libsta:=libsta or $2000;
if liberr<>0 then libsta:=libsta or -$8000;
asm mov bx,[bp] {vorhergehender Stapel}
les di,ss:[bx+6] {var ibcntl}
mov ax,[libcnt]
cwd
mov es:[di],ax
mov es:[di+2],dx
les di,ss:[bx+10] {var iberr}
mov ax,[liberr]
mov es:[di],ax
les di,ss:[bx+14] {var ibsta}
mov ax,[libsta]
mov es:[di],ax
end;
MakeResult:=libsta;
end;
function DLLibclr (ud: integer;
var ibsta,iberr: integer; var ibcntl: longint): integer; export;
begin
{$IFOPT D+} wvsprintf(DebugStr,'ibclr %d',ud); {$ENDIF}
if CheckUD(ud) then begin
iwsd('UNL UNT DCL',0);
end;
DLLibclr:=MakeResult;
end;
function DLLibeos (ud: integer; v: integer;
var ibsta,iberr: integer; var ibcntl: longint): integer; export;
{$IFOPT D+}
var vsrec: LongRec;
{$ENDIF}
begin
{$IFOPT D+}
vsrec.lo:=ud; vsrec.hi:=v;
wvsprintf(DebugStr,'ibeos %d v=%X',vsrec);
{$ENDIF}
if CheckUD(ud) then begin
eos[ud]:=eos[ud] and NI_EOT or v and NI_ALL; {nur merken}
end;
DLLibeos:=MakeResult;
end;
function DLLibeot (ud: integer; v: Bool;
var ibsta,iberr: integer; var ibcntl: longint): integer; export;
var before: Bool;
{$IFOPT D+}
var vsrec: LongRec;
{$ENDIF}
begin
{$IFOPT D+}
vsrec.lo:=ud; vsrec.hi:=Word(v);
wvsprintf(DebugStr,'ibeos %d v=%d',vsrec);
{$ENDIF}
if CheckUD(ud) then begin
before:=eos[ud] and NI_EOT <>0;
if v then eos[ud]:=eos[ud] or NI_EOT
else eos[ud]:=eos[ud] and not NI_EOT; {nur merken}
end;
DLLibeot:=MakeResult;
Bool(iberr):=before;
end;
function DLLibloc (ud: integer; {Diese Funktion tut nichts}
var ibsta,iberr: integer; var ibcntl: longint): integer; export;
begin
{$IFOPT D+} wvsprintf(DebugStr,'ibloc %d',ud); {$ENDIF}
if CheckUD(ud) then begin
iwsd('MTA LISTEN %d GTL UNL UNT',ud-MAGICBASE);
end;
DLLibloc:=MakeResult;
end;
function DLLibfind (udname : PChar;
var ibsta,iberr: Integer; var ibcntl: longint): integer; export;
var
ud,i: Integer;
s: array[0..7] of Char;
begin
{$IFOPT D+}
wvsprintf(DebugStr,'ibfind >%s<',udname);
asm int 3 end;
{$ENDIF}
DLLibfind:=-1;
if CheckBoard then begin
ud:=Integer(GetPrivateProfileInt(udname,'Pad',-1,PROFILE));
if ud<>-1 then begin
Inc(ud,MAGICBASE);
eos[ud]:=0;
i:=GetPrivateProfileInt(udname,'Tmo',0,PROFILE); {Was machen damit?}
i:=GetPrivateProfileInt(udname,'Eos',0,PROFILE);
WordRec(eos[ud]).lo:=Byte(i);
GetPrivateProfileString(udname,'Eot','Yes',s,sizeof(s),PROFILE);
if lstrcmpi(s,'No')<>0 then eos[ud]:=eos[ud] or NI_EOT;
GetPrivateProfileString(udname,'REos','No',s,sizeof(s),PROFILE);
if lstrcmpi(s,'Yes')=0 then eos[ud]:=eos[ud] or NI_REOS;
GetPrivateProfileString(udname,'XEos','No',s,sizeof(s),PROFILE);
if lstrcmpi(s,'Yes')=0 then eos[ud]:=eos[ud] or NI_XEOS;
GetPrivateProfileString(udname,'Bin','7-Bit',s,sizeof(s),PROFILE);
if lstrcmpi(s,'8-Bit')=0 then eos[ud]:=eos[ud] or NI_8BIT;
{$IFOPT D+} wvsprintf(DebugEnd,' eos=%X',eos[ud]); {$ENDIF}
DLLibfind:=ud;
end else libsta:=libsta or -$8000;
end;
MakeResult;
end;
function DLLibrd (ud: integer; var buf; cnt: longint;
var ibsta,iberr: Integer; var ibcntl: longint): integer; export;
{$IFOPT D+}
var
vsrec:record
i: Integer;
l: LongInt;
end;
vsrec2:record
s: PChar;
i: Integer;
end absolute vsrec;
{$ENDIF}
begin
{$IFOPT D+}
vsrec.i:=ud;
vsrec.l:=cnt;
wvsprintf(DebugStr,'ibrd %d cnt=%ld',vsrec);
{$ENDIF}
if CheckUD(ud) then begin
ReprogPorts(ud);
if (LongRec(cnt).hi<>0) or (LongRec(cnt).lo>MAXBUF)
then LongRec(cnt).lo:=MAXBUF; {Begrenzung}
with MemImg^ do begin
{$IFDEF OLDSTYLE}
args[0].lo:=Status;
args[1].lo:=ud-MAGICBASE;
args[2].lo:=LongRec(cnt).lo;
args[3].lo:=LongRec(cnt).lo;
args[3].hi:=sizeof(stack)+sizeof(args);
CallRom(39);
Status:=args[0].lo;
libcnt:=args[2].lo; {gelesene Bytes}
{$ELSE}
iwsd('MLA TALK %d',ud-MAGICBASE);
ReprogPorts(ud);
FillChar(args,sizeof(args),0);
args[0].lo:=Status;
args[2].lo:=LongRec(cnt).lo;
args[3].lo:=sizeof(stack)+sizeof(args);
args[3].hi:=mem.seg; {Segmentadresse}
CallRom(203);
Status:=args[0].lo;
libcnt:=args[1].lo; {gelesene Bytes?}
iwsd('UNL UNT',0);
{$ENDIF}
Move(buffer,buf,libcnt); {String komplett transferieren}
{$IFOPT D+}
vsrec2.s:=EscapeStr(PChar(@buf),libcnt);
vsrec2.i:=libcnt;
wvsprintf(DebugEnd,#10'returns >%s< (cnt=%d)',vsrec);
{$ENDIF}
end;
end;
DLLibrd:=MakeResult;
end;
function DLLibrsp (ud: integer; var spr : integer;
var ibsta,iberr: Integer; var ibcntl: longint) : integer; export;
begin
{$IFOPT D+} wvsprintf(DebugStr,'ibrsp %d',ud); {$ENDIF}
if CheckUD(ud) then begin
end;
{Diese Funktion tut nichts}
DLLibrsp:=MakeResult;
end;
function DLLibwrt (ud: integer; const buf; cnt: longint;
var ibsta,iberr: Integer; var ibcntl: longint): integer; export;
{$IFOPT D+}
var
vsrec:record
i: Integer;
l: LongInt;
eoi: Bool;
end;
vsrec2:record
s: PChar;
i: Integer;
end absolute vsrec;
{$ENDIF}
begin
{$IFOPT D+}
vsrec.i:=ud;
vsrec.l:=cnt;
if CheckUD(ud) then vsrec.eoi:=eos[ud] and NI_EOT <>0;
wvsprintf(DebugStr,'ibwrt %d cnt=%ld eoi=%u',vsrec);
{$ENDIF}
if CheckUD(ud) then begin
ReprogPorts(ud);
if (LongRec(cnt).hi<>0) or (LongRec(cnt).lo>MAXBUF)
then LongRec(cnt).lo:=MAXBUF; {Begrenzung}
with MemImg^ do begin
{$IFDEF OLDSTYLE}
Move(buf,buffer,LongRec(cnt).lo); {String komplett transferieren}
args[0].lo:=Status;
args[1].lo:=LongRec(cnt).lo;
args[1].hi:=sizeof(stack)+sizeof(args);
args[2].lo:=ud-MAGICBASE;
CallRom(36);
Status:=args[0].lo;
libcnt:=args[1].lo; {geschriebene Bytes?}
{$ELSE}
iwsd('MTA LISTEN %d',ud-MAGICBASE);
ReprogPorts(ud);
Move(buf,buffer,LongRec(cnt).lo); {String komplett transferieren}
FillChar(args,sizeof(args),0);
args[0].lo:=Status;
args[1].lo:=Word(eos[ud] and NI_EOT <>0);
args[2].lo:=LongRec(cnt).lo;
args[3].lo:=sizeof(stack)+sizeof(args);
args[3].hi:=mem.seg; {Segmentadresse}
CallRom(200);
Status:=args[0].lo;
libcnt:=args[2].lo; {geschriebene Bytes?}
iwsd('UNL UNT',0);
{$ENDIF}
{$IFOPT D+}
vsrec2.s:=EscapeStr(PChar(@buf),cnt);
vsrec2.i:=libcnt;
wvsprintf(DebugEnd,#10'sends >%s< (cnt=%d)',vsrec);
{$ENDIF}
end;
end;
DLLibwrt:=MakeResult;
end;
var
OldExit: Pointer;
procedure MyExit; far; {Ob diese aufgerufen wird?}
begin
ExitProc:=OldExit;
{$IFOPT D+}
asm int 3 end;
{$ENDIF}
if Mem.Sel<>0 then begin
GlobalUnlock(Mem.Sel);
GlobalDosFree(Mem.Sel);
end;
end;
exports
DLLibclr index 12,
DLLibeos index 19, {verwendet GPIBDSO}
DLLibeot index 20,
DLLibfind index 22,
DLLibloc index 27,
DLLibrd index 33,
DLLibrsp index 39, {verwendet GPIBDSO}
DLLibwrt index 48;
begin
RomSeg:=0;
Mem.Seg:=0;
OldExit:=ExitProc;
ExitProc:=@MyExit;
end.
| Detected encoding: OEM (CP437) | 1
|
|
|