{*******************************************************}
{                                                       }
{       SerCOM  1.2 (1) MS-DOS                          }
{                                                       }
{       Copyright (c) 1990,2000 DYNAMO Software         }
{                                                       }
{*******************************************************}

{
  Pascal Routinen f�r die Verwendung der seriellen
  Schnittstelle. Diese Unit existiert in 3 Versionen
  f�r folgende Plattformen:

  (1) MS-DOS     (Turbo Pascal)
  (2) Macintosh  (CodeWarrior)
  (3) Windows    (Delphi)

  Dieser Quellcode ist Freeware und darf NICHT verkauft
  werden. Download der aktuellen Version unter:

  www.dynamo-software.de/serial/code.htm

  Viel Spaá am Ger„t!
  Jens-Erich Lange
  info@dynamo-software.de
}

unit SerCom;

interface

const
  { Error Codes }
  SER_OK = 0;      { Kein Fehler }
  SER_NIL = -1;    { SerialPtr nicht initialisiert / Zuwenig RAM f�r Puffer }
  SER_ERR = -2;    { Unzul„ssige Parameter oder Schnittstelle geschlossen }
  SER_SYS = -3;    { Fehlermedlung vom Betriebssystem. Nummer in "SerialCode" }

  { Register Offsets f�r Portzugriffe }
  xRBR = $00;
  xTHR = $00;
  xDLR = $00;
  xIER = $01;
  xIIR = $02;
  xLCR = $03;
  xMCR = $04;
  xLSR = $05;
  xMSR = $06;


type
  SerialPtr = integer;
  SerialErr = longint;


{-------------------------------------------------------}
{  Initialisierung / Deinitialisierung                  }
{-------------------------------------------------------}
function SerialInit(PortNr, InBuffer, OutBuffer: integer): SerialPtr;
function SerialCode(SP: SerialPtr): SerialErr;
function SerialExit(SP: SerialPtr): SerialErr;

{-------------------------------------------------------}
{  ™ffnen / Schlieáen / Parametrieren                   }
{-------------------------------------------------------}
function SerialPara(SP: SerialPtr; Baud: longint; Data, Stop: integer; Parity: char): SerialErr;
function SerialOpen(SP: SerialPtr): SerialErr;
function SerialStop(SP: SerialPtr): SerialErr;

{-------------------------------------------------------}
{  Senden / Empfangen                                   }
{-------------------------------------------------------}
function SerialXmit(SP: SerialPtr; data: char): SerialErr;
function SerialRecv(SP: SerialPtr; var data: char): SerialErr;
function SerialDone(SP: SerialPtr): boolean;

function SerialRSet(SP: SerialPtr; xReg, Value: byte): SerialErr;
function SerialRGet(SP: SerialPtr; xReg: byte): SerialErr;


implementation


uses
  dos;

const
  SLOTS = 2;       { max. 2 Schnittstellen gleichzeitig benutzen }

  DLAB = $80;
  OCW1 = $21;
  OCW2 = $20;

  McrInit = $0F;
  Enable = $07;
  Disable = $00;


type
  RingBuffer = array [0..32000] of char;

  IHandler = record
    IirReg: byte;
    RegLSR: byte;
    RegMSR: byte;
    SysErr: integer;
    IntrSave: pointer;
    IntrNr: byte;
    IrqNr: byte;
    Offset: word;
    Param1: word;
    Param2: word;
    Limit_In: integer;
    Limit_Out: integer;
    Buffer_In: ^RingBuffer;
    Buffer_Out: ^RingBuffer;
    LastStored: integer;
    LastSent: integer;
    LastRead: integer;
    LastSaved: integer;
    XmitDone: boolean;
  end;

var
  IData: array [1..SLOTS] of IHandler;
  PortCom1: word absolute $0040: $0000;
  PortCom2: word absolute $0040: $0002;
  PortCom3: word absolute $0040: $0004;
  PortCom4: word absolute $0040: $0006;
  ExitSave: pointer;


procedure InitRecord(SP: SerialPtr);
begin
  with IData[SP] do
  begin
    SysErr := 0;
    IntrSave := nil;
    IntrNr := 0;
    IrqNr := 0;
    Offset := 0;
    Param1 := 0;
    Param2 := 0;
    Limit_In := 0;
    Limit_Out := 0;
    Buffer_In := nil;
    Buffer_Out := nil;
    LastStored := 0;
    LastSent := 0;
    LastRead := 0;
    LastSaved := 0;
    XmitDone := true;
  end;
end;


{$F+}

procedure HandlerA;
INTERRUPT;
begin
  inline($FB);
  port[OCW2] := $20;
  with IData[1] do
  begin
    repeat
      IirReg := port[Offset + xIIR];
      case IirReg of
        6: RegLSR := Port[Offset + xLSR];
        4: begin
            Buffer_In^[LastSaved] := char(Port[Offset + xRBR]);
            LastSaved := (LastSaved + 1) mod Limit_In;
          end;
        2: begin
            if LastSent <> LastStored then
            begin
              port[Offset + xTHR] := ord(Buffer_Out^[LastSent]);
              LastSent := (LastSent + 1) mod Limit_Out;
            end
            else XmitDone := true;
          end;
        0: RegMSR := Port[Offset + xMSR];
      end;
    until IirReg = 1;
  end;
end;

procedure HandlerB;
INTERRUPT;
begin
  inline($FB);
  port[OCW2] := $20;
  with IData[2] do
  begin
    repeat
      IirReg := port[Offset + xIIR];
      case IirReg of
        6: RegLSR := Port[Offset + xLSR];
        4: begin
            Buffer_In^[LastSaved] := char(Port[Offset + xRBR]);
            LastSaved := (LastSaved + 1) mod Limit_In;
          end;
        2: begin
            if LastSent <> LastStored then
            begin
              port[Offset + xTHR] := ord(Buffer_Out^[LastSent]);
              LastSent := (LastSent + 1) mod Limit_Out;
            end
            else XmitDone := true;
          end;
        0: RegMSR := Port[Offset + xMSR];
      end;
    until IirReg = 1;
  end;
end;

procedure ExitCode;
var
  Err: SerialErr;
  Slot: integer;
begin
  ExitProc := ExitSave;
  for Slot := 1 to SLOTS do Err := SerialExit(Slot);
end;

{$F-}


procedure SetParameter(SP: SerialPtr);
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      port[Offset + xLCR] := port[Offset + xLCR] or DLAB;
      portW[Offset + xDLR] := Param1;
      port[Offset + xLCR] := Param2;
      LastSent := 0;
      LastStored := 0;
      LastRead := 0;
      LastSaved := 0;
      XmitDone := true;
    end;
end;


procedure SetIrqLevel(Level: byte);
var
  Mask: byte;
  Value: byte;
begin
  Mask := not (1 shl Level);
  Value := port[OCW1];
  Value := Value and Mask;
  port[OCW1] := Value;
end;


{ private }
{----------------------------------------------------------------------}
{ public }


{----------------------------------------------------------------------}
{  Funktion "SerialInit"                                               }
{  initialisiert die Verwendung der seriellen Schnittstelle. Diese     }
{  Funktion wird �blicherweise einmal zu Beginn des Programms aufge-   }
{  rufen.                                                              }
{  Der Parameter PortNr bezeichnet die zu verwendende Schnittstelle.   }
{  Die Parameter InBuffer und OutBuffer geben die GrӇe der Zwischen-  }
{  puffer f�r das asynchrone Senden und Empfangen an.                  }
{  Eine typische GrӇe von InBuffer und OutBuffer ist 1024.            }
{  Das Ergebnis der Funktion ist ein Handle f�r die zu verwendende     }
{  Schnittstelle. In allen weiteren Routinen muá dieses Handle         }
{  angegeben werden. Durch die Identifizierung �ber ein Handle ist es  }
{  m”glich mehrere Schnittstellen gleichzeitig zu ”ffnen. Das Gegen-   }
{  st�ck zu "SerialInit" ist die Funktion "SerialExit".                }
{----------------------------------------------------------------------}

function SerialInit(PortNr, InBuffer, OutBuffer: integer): SerialPtr;
var
  Err: SerialErr;
  Slot: SerialErr;
begin
  Slot := 0;
  repeat
    inc(Slot);
  until (IData[Slot].IntrSave = nil) or (Slot > SLOTS);

  if (Slot <= SLOTS) then with IData[Slot] do
    begin
      if (MaxAvail > InBuffer + OutBuffer) then
      begin
        case PortNr of
          1: begin
              IntrNr := $0C;
              IrqNr := 4;
              Offset := PortCom1;
            end;
          2: begin
              IntrNr := $0B;
              IrqNr := 3;
              Offset := PortCom2;
            end;
          3: begin
              IntrNr := $0C;
              IrqNr := 4;
              Offset := PortCom3;
            end;
          4: begin
              IntrNr := $0B;
              IrqNr := 3;
              Offset := PortCom4;
            end;
        end;
        if (Offset <> 0) then
        begin
          Limit_In := InBuffer;
          Limit_Out := OutBuffer;
          GetMem(Buffer_In, Limit_In);
          GetMem(Buffer_Out, Limit_Out);
          port[Offset + xIER] := Disable;
          inline($FA);
          getintvec(IntrNr, IntrSave);
          case Slot of
            1: setintvec(IntrNr, @HandlerA);
            2: setintvec(IntrNr, @HandlerB);
          end;
          SetIrqLevel(IrqNr);
          inline($FB);
          Err := SerialPara(Slot, 9600, 8, 1, 'N');
        end
        else Slot := SER_ERR;
      end
      else Slot := SER_ERR;
    end
  else Slot := SER_ERR;
  SerialInit := Slot;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialCode"                                               }
{  gibt eine erweiterte Fehlermeldung zur�ck wenn eine andere Routine  }
{  zuvor das Ergebnis "SER_SYS" (-3) geliefert hat. Die Fehlernummer   }
{  ist die Io-Meldung des Betriebssystems.                             }
{----------------------------------------------------------------------}

function SerialCode(SP: SerialPtr): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      SerialCode := SysErr;
      SysErr := 0;
    end
  else SerialCode := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialExit"                                               }
{  ist das Gegenst�ck zu "SerialInit". Diese Funktion gibt den beleg-  }
{  ten Speicher f�r das Handle zu einer Schnittstelle wieder frei.     }
{  Ist die Schnittstelle zum Zeitpunkt des Aufrufes noch ge”ffnet, so  }
{  wird sie zun„chst geschlossen.                                      }
{----------------------------------------------------------------------}

function SerialExit(SP: SerialPtr): SerialErr;
var Err: SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      if (IntrSave <> nil) then
      begin
        Err := SerialStop(SP);
        inline($FA);
        setintvec(IntrNr, IntrSave);
        inline($FB);
        if Limit_In > 0 then FreeMem(Buffer_In, Limit_In);
        if Limit_Out > 0 then FreeMem(Buffer_Out, Limit_In);
        InitRecord(SP);
        SerialExit := SER_OK;
      end
      else SerialExit := SER_ERR;
    end
  else SerialExit := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialPara"                                               }
{  parametriert die serielle Schnittstelle. Es ist dabei unerheblich,  }
{  ob die Schnittstelle bereits ge”ffnet ist oder nicht.               }
{  F�r eine ordentliche Kommunikation ist es erforderlich, daá alle    }
{  Parameter mit denen der Gegenstelle �bereinstimmen. Viele Modems    }
{  k”nnen die verwendeten Parameter selbst„ndig erkennen und k”nnen    }
{  daher mit verschiedenen Parametern angesprochen werden.             }
{  Die Standardeinstellung f�r Daten- und Stopbits sowie Parit„t sind  }
{  8 - 1 - Keine (None).                                               }
{----------------------------------------------------------------------}

function SerialPara(SP: SerialPtr; Baud: longint; Data, Stop: integer; Parity: char): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      Param1 := 115200 div Baud;
      case Data of
        5: Param2 := 0;
        6: Param2 := 1;
        7: Param2 := 2;
        8: Param2 := 3;
      end;
      case Stop of
        1: Param2 := Param2 + 0;
        2: Param2 := Param2 + 4;
      end;
      case Parity of
        'N': Param2 := Param2 + 0;
        'O': Param2 := Param2 + 8;
        'E': Param2 := Param2 + 24;
      end;
      if (IntrSave <> nil) then
      begin
        SetParameter(SP);
        SerialPara := SER_OK;
      end
      else SerialPara := SER_ERR;
    end
  else SerialPara := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialOpen"                                               }
{  ”ffnet die serielle Schnittstelle und erm”glicht somit den Daten-   }
{  verkehr. Nachdem die Schnittstelle ge”ffnet ist, werden alle ein-   }
{  gehenden Zeichen im Zwischenpuffer gespeichert bis diese mit der    }
{  Funktion "SerialRecv" aus dem Puffer entnommen werden.              }
{  Das Gegenst�ck zu "SerialOpen" ist die Funktion "SerialStop".       }
{  Die Zwischenpuffer werden beim ”ffnen und schlieáen einer Schnitt-  }
{  stelle gel”scht.                                                    }
{----------------------------------------------------------------------}

function SerialOpen(SP: SerialPtr): SerialErr;
var Dummy: byte;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      if (IntrSave <> nil) then
      begin
        SetParameter(SP);
        port[Offset + xMCR] := McrInit;
        Dummy := port[Offset + xRBR];
        Dummy := port[Offset + xLSR];
        port[Offset + xIER] := Enable;
        SerialOpen := SER_OK;
      end
      else SerialOpen := SER_ERR;
    end
  else SerialOpen := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialStop"                                               }
{  schlieát die serielle Schnittstelle. Die Datenkommunikation wird    }
{  unterbunden und der Gegenstelle wird auf den Handshakeleitungen     }
{  signalisiert, daá die Schnittstelle geschlossen ist. Ein ordent-    }
{  lich konfiguriertes Modem sollte dadurch eine bestehende Telefon-   }
{  verbindung trennen.                                                 }
{----------------------------------------------------------------------}

function SerialStop(SP: SerialPtr): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      if (IntrSave <> nil) then
      begin
        port[Offset + xIER] := 0;
        port[Offset + xMCR] := 0;
        SerialStop := SER_OK;
      end
      else SerialStop := SER_ERR;
    end
  else SerialStop := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialXmit"                                               }
{  �bergibt ein Zeichen an den Sendepuffer. Falls die Schnittstelle    }
{  zu diesem Zeitpunkt ge”ffnet ist, werden die Zeichen im Hinter-     }
{  grund asynchron �bertragen. Die Funktion kehrt nach ihrem Aufruf    }
{  schnell zur�ck und wartet nicht auf das Ende der šbertragung.       }
{  Zeichenketten und bin„re Arrays werden vom Aufrufer in einer        }
{  Schleife an diese Funktion �bergeben.                               }
{  Mit der Funktion "SerialDone" kann gepr�ft werden, ob schon alle    }
{  Zeichen �bertragen wurden.                                          }
{----------------------------------------------------------------------}

function SerialXmit(SP: SerialPtr; data: char): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      Buffer_Out^[LastStored] := data;
      LastStored := (LastStored + 1) mod Limit_Out;
      if XmitDone then
      begin
        XmitDone := false;
        port[Offset + xTHR] := ord(Buffer_Out^[LastSent]);
        LastSent := (LastSent + 1) mod Limit_Out;
      end;
      SerialXmit := 1;
    end
  else SerialXmit := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialRecv"                                               }
{  holt das n„chste Zeichen aus dem Empfangspuffer. Voraussetzung ist  }
{  eine ge”ffnete Schnittstelle. Ist das Ergebnis dieser Funktion "1"  }
{  so wurde die Funktion erfolgreich ausgef�hrt. Alle anderen Werte    }
{  bedeuten, daá kein Zeichen empfangen wurde.                         }
{----------------------------------------------------------------------}

function SerialRecv(SP: SerialPtr; var data: char): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      if LastSaved <> LastRead then
      begin
        data := Buffer_In^[LastRead];
        LastRead := (LastRead + 1) mod Limit_In;
        SerialRecv := 1;
      end
      else SerialRecv := 0;
    end
  else SerialRecv := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialDone"                                               }
{  ermittelt, ob alle Zeichen im Sendepuffer schon �bertragen wurden.  }
{----------------------------------------------------------------------}

function SerialDone(SP: SerialPtr): boolean;
begin
  SerialDone := IData[SP].XMitDone;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialRSet"                                               }
{  Low-Level Routine (nur in dieser MS-DOS Version vorhanden).         }
{  Setzt die Register des seriellen Schnittstellenbausteins.           }
{----------------------------------------------------------------------}

function SerialRSet(SP: SerialPtr; xReg, Value: byte): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      port[Offset + xReg] := Value;
      SerialRSet := SER_OK;
    end
  else SerialRSet := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialRGet"                                               }
{  Low-Level Routine (nur in dieser MS-DOS Version vorhanden).         }
{  Liest die Register des seriellen Schnittstellenbausteins.           }
{----------------------------------------------------------------------}

function SerialRGet(SP: SerialPtr; xReg: byte): SerialErr;
begin
  if (SP > 0) and (SP <= SLOTS) then with IData[SP] do
    begin
      SerialRGet := port[Offset + xReg];
    end
  else SerialRGet := SER_NIL;
end;


begin
  ExitSave := ExitProc;
  ExitProc := @ExitCode;
  InitRecord(1);
  InitRecord(2);
end.