Source file: /~heha/messtech/ho80.zip/GPIB.PAS

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
Wrong umlauts? - Assume file is ANSI (CP1252) encoded