<<< async.pas >>>
{$R-,S-,I-,D+,T+,F-,V+,B-,N-,L+ }
UNIT ASYNC;

INTERFACE

Uses Delays;

(**************************** ASYNC.PAS *********************************)
(*                                                                      *)
(*     Modul for bruk av 1,2,3 el. 4 COM-porter samtidig, med interrupt *)
(*     bde ved sending og mottak og uavhengige ring-buffere opptil     *)
(*     64k for hver retning og port.                                    *)
(*                                                                      *)
(*     Oslo, November 1987 Terje Mathisen, Norsk Hydro                  *)
(*                                                                      *)
(**************************** ASYNC.PRO *********************************)

CONST RX_int     = 1;
      TX_int     = 2;
      RLS_int    = 4;
      MODEM_int  = 8;
      SumOf_int  =15;
TYPE
  ComPortType = 1..4;
  ParityType = (No_Parity, Even_Parity, Odd_Parity, Zero_Parity, One_Parity);

  RS_IntSet = 0..SumOf_int;
  RS_BufPtrType  = ^RS_BufferType;
  RS_BufferType = RECORD
              ICadr, IntNr     : WORD;

              oldModemContrReg : BYTE;
              oldLevel  : BYTE;
              oldVector : Pointer;

              xin : Pointer;
              xout, SizeX, LimitX    : WORD;

              Tin : WORD;
              Tout : Pointer;
              SizeT, SendFirst : WORD;

              ShowXoffPtr : Pointer;
              Toggle_Xoff, RLS_user, MODEM_user : Pointer;

              Ctrl_P    : BYTE;  {0 - > default, 1..4 -> NOTIS}

              UseTint, HostXoff : BOOLEAN;
              Bufferfilled : BYTE;

              AutoXoff, AltXoff : BOOLEAN;
              Xoff1C, Xoff2C, Xon1C, Xon2C     : CHAR;

              Line_Status, MODEM_status : BYTE;
              WaitTX : BOOLEAN;
              Int_Mask : BYTE;
              oldIntEnableReg : BYTE;
            END;

VAR
  RS_BufPtr : ARRAY [ComPortType] OF RS_BufPtrType;
  RS_TimeOut : WORD;

  RS_Buffer : ARRAY [ComPortType] OF RS_BufferType; { Must be in data-seg! }

  PROCEDURE RS_MakeBuffer(Rsize,Tsize,IOaddr,SWint:WORD; com : WORD);

  PROCEDURE RS_Init (baudRate : LongInt;
                  NbrOfBits,           { 5|6|7|8 }
                  StopBits: WORD;      { 1|2 }
                  Parity: ParityType;
            { (No_Parity, Even_Parity, Odd_Parity, Zero_Parity, One_Parity) }
                  VAR result: BOOLEAN;
                  com: ComPortType); { 1..4 }

  PROCEDURE RS_Stop(com: ComPortType);

  PROCEDURE RS_Start(rs_int: RS_IntSet; com: ComPortType);

  PROCEDURE RS_BusyRead(VAR ch:CHAR;VAR done : BOOLEAN; com : WORD);

  PROCEDURE RS_ReadBlock(VAR buf;max:WORD;VAR bytes:WORD;com : WORD);

  PROCEDURE RS_Write(ch: CHAR;VAR done : BOOLEAN; com: WORD );

  PROCEDURE RS_WriteBlock(VAR buf;len: WORD;VAR bytes:WORD; com: WORD);

  FUNCTION RS_GetChar(VAR ch : CHAR; com : WORD): BOOLEAN;

  FUNCTION RS_Avail(com : WORD): WORD;

  FUNCTION RS_Room(com : WORD): WORD;

  PROCEDURE RS_Enable(com : WORD);

  PROCEDURE RS_WriteFirst(ch:CHAR;com:WORD);

  PROCEDURE RS_ClrBuffer(com: WORD);

  PROCEDURE RS_Set_TX_Int(rs_int : RS_IntSet; com : WORD);

  FUNCTION RS_Empty(com : WORD) : BOOLEAN;

  PROCEDURE RS_Break(ms : WORD;com : WORD);

  PROCEDURE RS_StopLink(com : WORD);

  PROCEDURE RS_StartLink(com : WORD);

  PROCEDURE RS_StopAll;

IMPLEMENTATION

CONST
  LineContrReg    = 3; { to specify format of transmitted data }
  LowBaudRateDiv  = 0; { lower byte of divisor to select baud rate }
  HighBaudRateDiv = 1; { higher byte of divisor }
  LineStatusReg   = 5; { holds status info on the data transfer }
  ReceiverReg     = 0; { received CHAR is in this register }
  TransmitReg     = 0; { CHAR to send is put in this reg }
  IntEnableReg    = 1; { to enable the selected interrupt }
  IntIdentReg     = 2;
  ModemContrReg   = 4; { controls the interface to a modem }

    PROCEDURE GetAlignMem(VAR p : Pointer; size : WORD);
    VAR temp : ^BYTE;
    BEGIN
      REPEAT
        GetMem(p,size);
        IF Ofs(p^) = 0 THEN Exit;
        FreeMem(p,size);
        New(temp);
      UNTIL FALSE;
    END;

  PROCEDURE RS_MakeBuffer(Rsize, Tsize, IOaddr, SWint, com: WORD);
  CONST PortTab : ARRAY [ComPortType] OF WORD = ($3F8,$2F8,$3E8,$2E8);
        IntTab  : ARRAY [ComPortType] OF BYTE = (12,11,12,11);
  VAR c, c0, c1 : WORD;
  BEGIN
    IF Rsize + Tsize > MemAvail - $100 THEN BEGIN
      Halt(1);
    END;
    IF com = 0 THEN BEGIN
      c0 := 1; c1 := 4;
    END
    ELSE BEGIN
      IF com > 4 THEN Halt(1);
      c0 := com; c1 := com;
    END;
    FOR c := c0 TO c1 DO WITH RS_Buffer[c] DO BEGIN
      IF (com = 0) AND (c > 1) THEN
        RS_Buffer[c] := RS_Buffer[1]
      ELSE BEGIN
        IF Rsize > 0 THEN BEGIN
          GetAlignMem(xin,Rsize);
          SizeX := Rsize;
          LimitX := Rsize DIV 8;
        END;

        IF Tsize > 0 THEN BEGIN
          GetAlignMem(Tout,Tsize);
          SizeT := Tsize;
        END;
      END;

      IF IOaddr = 0 THEN
        ICadr := PortTab[c]
      ELSE
        ICadr := IOaddr;

      IF SWint = 0 THEN
        IntNr := IntTab[c]
      ELSE
        IntNr := SWint;

{                       Disse variablene er nullstilt allerede!
      xin := 0;
      xout := 0;
      SendFirst := 0;
      tin := 0;
      tout := 0;
      Ctrl_P := 0;
      UseTint := FALSE;
      Sending := FALSE;
      Receiving := FALSE;
      HostXoff := FALSE;
      BufferFilled := 0;
      AltXoff  := FALSE;
      ShowXoffPtr := NIL;
      Toggle_Xoff := 0;
      RLS_user := 0;
      MODEM_user := 0;
}
                                       {Default to use XON/XOFF!}
      AutoXoff := TRUE;
      Xoff1C   := ^S;
      Xon1C    := ^Q;
    END;
  END;

  PROCEDURE RS_Init (baudRate  : LongInt;
                  NbrOfBits,           { 5|6|7|8 }
                  StopBits: WORD;      { 1|2 }
                  Parity: ParityType;
            { (No_Parity, Even_Parity, Odd_Parity, Zero_Parity, One_Parity) }
                  VAR result: BOOLEAN;
                  com: ComPortType); { 1..4 }
  CONST ParityTab : ARRAY [ParityType] OF BYTE = (0,$18,$08,$38,$28);
    VAR divisor : WORD;
        parameters: BYTE;

  BEGIN (* Init *)
    result := FALSE;

    WITH RS_Buffer[com] DO BEGIN
      IF Xin = NIL THEN BEGIN          {No buffer allocated!}
        Halt(1);
      END;

    (* load the divisor of the baud rate generator: *)
      IF baudrate < 1 THEN Exit;
      divisor := (115200 + (baudrate DIV 2)) DIV baudrate;
      Port[ICadr+LineContrReg] := $80;
      Port[ICadr+HighBaudRateDiv] := Hi(divisor);
      Port[ICadr+LowBaudRateDiv]  := Lo(divisor);

        (* prepare the parameters: *)
      parameters := ParityTab[Parity];

      IF stopBits = 2 THEN
        parameters := parameters + 4
      ELSE IF stopBits <> 1 THEN Exit;

      IF (nbrOfBits < 5) OR (nbrOfBits > 8) THEN Exit;
      Port[ICadr+LineContrReg] := parameters + (nbrOfBits - 5);

        (* Disable Interrupts: *)
      Port[ICadr+IntEnableReg] := 0;
      result := TRUE;
    END;
  END                                  { Init };

    CONST
      I8259ContrWord1 = $21;  (* Interrupt controller,
                                 Operation Control Word 1 *)

(************************* ASSEMBLER ROUTINES FOR MAX SPEED ****************)

    PROCEDURE RS_Com1Int;                            EXTERNAL;

    PROCEDURE RS_Com2Int;                            EXTERNAL;

    PROCEDURE RS_Com3Int;                            EXTERNAL;

    PROCEDURE RS_Com4Int;                            EXTERNAL;

    PROCEDURE RS_BusyRead(VAR ch:CHAR;VAR done : BOOLEAN;
              com : WORD);                    EXTERNAL;

    PROCEDURE RS_ReadBlock(VAR buf;max:WORD;
              VAR bytes : WORD;com : WORD);EXTERNAL;

    PROCEDURE RS_Write(ch: CHAR;VAR done : BOOLEAN;
              com: WORD );                    EXTERNAL;

    PROCEDURE RS_WriteBlock(VAR buf;len: WORD;
              VAR bytes : WORD; com: WORD);EXTERNAL;

    FUNCTION RS_GetChar(VAR ch : CHAR;
             com : WORD): BOOLEAN;            EXTERNAL;

    FUNCTION RS_Avail(com : WORD): WORD;   EXTERNAL;

    FUNCTION RS_Room(com : WORD): WORD;    EXTERNAL;

    PROCEDURE RS_Enable(com : WORD);          EXTERNAL;

    PROCEDURE RS_WriteFirst(ch:CHAR;com:WORD);EXTERNAL;

  {$L ASYNC.OBJ}

(***************************************************************************)

VAR vect_tab : ARRAY [0..255] OF Pointer ABSOLUTE 0:0;

PROCEDURE Disable; Inline($FA);

PROCEDURE Enable; Inline($FB);

PROCEDURE GetVector(vnr : WORD; VAR vector : Pointer);
BEGIN
  vector := vect_tab[vnr];
END;                                   {GetVector}

PROCEDURE SetVector(vnr : WORD; vector : Pointer);
BEGIN
  Disable;
    vect_tab[vnr] := vector;
  Enable;
END;                                   {PutVector}

PROCEDURE RS_Start(rs_int : RS_IntSet; com: ComPortType);
VAR
  adr : Pointer;
  mask, tempSet : BYTE;
  dummy : WORD;
  ch : CHAR;
  ok : BOOLEAN;
BEGIN
  WITH RS_Buffer[com] DO
    IF OldVector = NIL THEN BEGIN

      (* enable interrupts in the interrupt controller (8259): *)
      tempSet := Port[I8259ContrWord1];
      (* set the interrupt vector *)

      GetVector(IntNr,OldVector);
      CASE com OF
        1 : adr := @RS_Com1int;
        2 : adr := @RS_Com2int;
        3 : adr := @RS_Com3int;
        4 : adr := @RS_Com4int;
      END;
      SetVector(IntNr,adr);

      mask := 1 Shl (IntNr - 8);
      oldLevel := tempSet AND mask;

      DISABLE;
      Port[I8259ContrWord1] := tempSet AND NOT mask;

      dummy  :=  Port[ICadr+IntIdentReg] +
                 Port[ICadr+LineStatusReg] +
                 Port[ICadr+ModemContrReg] +
                 Port[ICadr+ReceiverReg];    (* clear the controller *)

      WORD(xin)    := 0;
      xout         := 0;

      SendFirst    := 0;
      tin          := 0;
      WORD(tout)   := 0;

      HostXoff     := FALSE;
      WaitTX       := FALSE;
{      AutoXoff     := TRUE;      }
      BufferFilled := 0;
      Line_Status  := 0;
      MODEM_Status := 0;

      tempSet := Port[ICadr+ModemContrReg];
      oldModemContrReg := tempSet AND 11;    { DTR and RTS }

      Port[ICadr+ModemContrReg] := tempSet OR 11;

      Int_Mask := rs_int;
      oldIntEnableReg := Port[ICadr+IntEnableReg];
      Port[ICadr+IntEnableReg] := rs_int;
      UseTint := (TX_int AND rs_int) <> 0;

      ENABLE;

    END;
    dummy := 50;
    REPEAT
      RS_BusyRead(ch,ok,com);               { Remove pending int's }
      Dec(dummy);
    UNTIL NOT ok OR (dummy = 0);
END                                {RS_Start};

PROCEDURE RS_Stop(com: ComPortType);
BEGIN
  WITH RS_Buffer[com] DO
    IF OldVector <> NIL THEN BEGIN
      DISABLE;

    (* restore old mask in 8259: *)
      Port[I8259ContrWord1] := Port[I8259ContrWord1] OR oldLevel;

    (* disable interrupts in 8250: *)
      Port[ICadr+IntEnableReg] := oldIntEnableReg;
    (* restore modem control register in 8250: *)
      Port[ICadr+ModemContrReg] :=
         (Port[ICadr+ModemContrReg] AND 244) OR oldModemContrReg;
      ENABLE;

    (* restore the old interrupt vector *)
      SetVector(IntNr,OldVector);
      OldVector := NIL;
    END;
END                                {RS_Stop};
(*
PROCEDURE RS_Read(VAR ch: CHAR;com: WORD );
VAR done : BOOLEAN;
BEGIN
  REPEAT
    RS_BusyRead (ch, done, com);
  UNTIL done;
END                                {RS_Read};
*)
PROCEDURE RS_ClrBuffer(com: WORD);
BEGIN
  WITH RS_Buffer[com] DO BEGIN
    Disable;
    WORD(xin) := 0;
    xout := 0;
    tin := 0;
    WORD(tout) := 0;
    SendFirst := 0;
    Enable;
  END;
END;                               {ClrBuffer}

PROCEDURE RS_Set_TX_Int(rs_int : RS_IntSet; com : WORD);
BEGIN
  WITH RS_Buffer[com] DO BEGIN
    Disable;
    tin := 0;
    WORD(tout) := 0;
    SendFirst := 0;
    Int_Mask := rs_int;
    Port[ICadr+IntEnableReg] := rs_int;
    UseTint := (TX_int AND rs_int) <> 0;
    Enable;
  END;
END;                               {RS_Set_TX_Int}

FUNCTION RS_Empty(com : WORD) : BOOLEAN;
VAR ch : CHAR;
    ok : BOOLEAN;
BEGIN
  WITH RS_Buffer[com] DO
    RS_Empty := WORD(xin) = xout;
END;                                 {EmptyBuffer}

PROCEDURE RS_Break(ms : WORD;com : WORD);
VAR oldreg : BYTE;
BEGIN
  WITH RS_Buffer[com] DO BEGIN
    WaitTX := TRUE;
    WHILE Port[ICadr+LineStatusReg] AND 32 = 0 DO ; { wait for no traffic }
    oldreg := Port[ICadr+LineContrReg];
    Port[ICadr+LineContrReg]:= oldreg OR 64;
    Delay(ms);
    Port[ICadr+LineContrReg] := OldReg;
    Delay(250);
    WaitTX := FALSE;
    IF NOT HostXoff THEN RS_Enable(com);
  END;
END;                                 {RS_Break}

PROCEDURE RS_StopLink(com : WORD);
VAR bf : BYTE;
BEGIN
  WITH RS_Buffer[com] DO
    IF AutoXoff THEN BEGIN
      Disable;
      bf := BufferFilled;
      BufferFilled := BufferFilled OR 2;
      Enable;
      IF bf = 0 THEN BEGIN
        RS_WriteFirst(Xoff1C,com);
        Delay(10);
      END;
    END;
END;

PROCEDURE RS_StartLink(com : WORD);
VAR bf : BYTE;
BEGIN
  WITH RS_Buffer[com] DO
    IF AutoXoff THEN BEGIN
      Disable;
      BufferFilled := BufferFilled AND 253;
      bf := BufferFilled;
      Enable;
      IF bf = 0 THEN BEGIN
        RS_WriteFirst(Xon1C,com);
      END;
    END;
END;

VAR SaveExit : Pointer;

PROCEDURE RS_StopAll;
BEGIN
  RS_Stop(1);
  RS_Stop(2);
  RS_Stop(3);
  RS_Stop(4);
  ExitProc := SaveExit;
END;

BEGIN
  FillChar(RS_Buffer,SizeOf(RS_Buffer),#0);
  RS_BufPtr[1] := Addr(RS_Buffer[1]);
  RS_BufPtr[2] := Addr(RS_Buffer[2]);
  RS_BufPtr[3] := Addr(RS_Buffer[3]);
  RS_BufPtr[4] := Addr(RS_Buffer[4]);
  RS_TimeOut := 0;
  SaveExit := ExitProc;
  ExitProc := @RS_StopAll;
END.
<<< async.sal >>>
; ASYNC.SAL Driver for RS232 fra Turbo Pascal V4
; Version 2.0
;     Date: 87-11-19, 20:10

            saljmp short
            salcmp unsigned
            salmac :=     mov &-,&+

include pascal.mac

buffers struc
    PortNr  dw ?
    IntNr   dw ?

    oldModemCntrReg db ?
    oldLevel        db ?
    oldVector       dd ?

    Inx     dw ?
    R_Buf2  dw ?
    OutX    dw ?
    SizeX   dw ?
    LimitX  dw ?

    InT     dw ?
    OutT    dw ?
    T_Buf2  dw ?
    SizeT   dw ?
    Send_T  dw ?

    Show_X  dw ?
    Show_X2 dw ?

    Toggle_Xoff dd ?
    RLS_user    dd ?
    MODEM_user  dd ?

    Ctrl_P  db ?

    UseTInt db ?
    HostX   db ?
    Bfull   db ?

    AutoX   db ?
    AltX    db ?

    Xoff1C  db ?
    Xoff2C  db ?
    Xon1C   db ?
    Xon2C   db ?

    Line_Status  db ?
    MODEM_Status db ?

    WaitTX  db ?
    Int_Mask db ?

buffers ends

DXofs MACRO ofs
    mif ofs
        ife ofs - 1
            inc dx
        else
            ife ofs + 1
                dec dx
            else
                add dx,ofs
            endif
        endif
    endif
ENDM

InPort MACRO ofs
    dx := [bx.PortNr]
    DXofs <ofs>
    in al,dx
ENDM

OutPort MACRO ofs
    dx := [bx.PortNr]
    DXofs <ofs>
    out dx,al
ENDM

InPOfs MACRO ofs
    DXofs <ofs>
    in al,dx
ENDM

OutPOfs MACRO ofs
    DXofs <ofs>
    out dx,al
ENDM

    LineContrReg    = 3   ; (* to specify format of transmitted data *)
    LowBaudRateDiv  = 0   ; (* lower byte of divisor to select baud rate *)
    HighBaudRateDiv = 1   ; (* higher byte of divisor *)
    LineStatusReg   = 5   ; (* holds status info on the data transfer *)
    ReceiverReg     = 0   ; (* received CHAR is in this register *)
    TransmitReg     = 0   ; (* CHAR to send is to put in this reg *)
    IntEnableReg    = 1   ; (* to enable the selected interrupt *)
    IntIdentReg     = 2   ; (* to identify the interrupt *)
    ModemContrReg   = 4   ; (* controls the interface to a modem *)
    ModemStatusReg  = 6   ; (* holds status of line (BREAK etc.) *)

    Icntrlw2 = 20h                     ;Interrupt controller
    SEOI1    = 64h                     ;EOI for COM1
    SEOI2    = 63h                     ;EOI for COM2

    FALSE    = 0
    TRUE     = 1

    RLSint   = 6
    RDRint   = 4
    THREint  = 2
    MODEMint = 0

DATA SEGMENT WORD PUBLIC
    ASSUME DS:DATA

EXTRN RS_BufPtr:WORD
EXTRN RS_TimeOut:WORD
DATA ENDS

CODE SEGMENT BYTE PUBLIC
    ASSUME CS:CODE

    public Rs_Com4int
Rs_Com4int proc far
    push ax
    push bx
    mov bx,offset DATA:rs_bufptr[12]
    jmp short comcont

    public rs_com3int
rs_com3int proc far
    push ax
    push bx
    mov bx,offset DATA:rs_bufptr[8]
    jmp short comcont

    public rs_com2int
rs_com2int proc far
    push ax
    push bx
    mov bx,offset DATA:rs_bufptr[4]
    jmp short comcont

    public rs_com1int
rs_com1int proc far
    push ax
    push bx
    mov bx,offset DATA:rs_bufptr[0]
comcont:
    push ds
    mov ax, DATA
    mov ds,ax
ASSUME DS:DATA

    mov bx,[bx]

; Reset Video TimeOut Count
    rs_timeout := 0

;   STI                                ;Enable int's

    push cx
    push dx
    push di
    push si
    push es

repeat_int:

    CLI
    InPort IntIdentReg                 ;Hvorfor er jeg her?

    if al = RDRint then
        call ReadInt
        jmp repeat_int
    endif
    if al = THREint then               ;TX int
        call SendNext                  ;Restart
        jmp repeat_int
    endif
    if al = RLSint then
        InPOfs <LineStatusReg - IntIdentReg>
        and al,1Eh                     ;Keep OE(2),PE(4),FE(8) and BI(10)
        or [bx.Line_Status],al
        jmp repeat_int
    endif
    if al = MODEMint then
        InPOfs <ModemStatusReg-IntIdentReg> ;Restart async chip
        or [bx.MODEM_Status],al
        if word ptr [bx].MODEM_user <> 0 then
            push bx
            push ds
            call dword ptr [bx+MODEM_user]
            pop ds
            pop bx
        endif
        jmp repeat_int
    endif

    InPOfs <ModemStatusReg-IntIdentReg> ;Restart async chip
    or [bx.MODEM_Status],al
    jmp $+2
    InPOfs <LineStatusReg-ModemStatusReg>
    and al,1Eh                         ;Keep OE(2),PE(4),FE(8) and BI(10)
    or [bx.Line_Status],al

    pop  es
    pop  si
    pop  di
    pop  dx
    pop  cx

    pop  ds
    pop  bx

; Enable HW int's

    CLI
    al := 20h
    out Icntrlw2,al

    pop  ax
    iret
rs_com1int endp
rs_com2int endp
rs_com3int endp
rs_com4int endp

ReadInt Proc near

    InPOfs <ReceiverReg - IntIdentReg> ;Get received char

; Test if room in buffer

    les si,dword ptr [bx.InX]          ;Get buffer Address
    lea di,[si+1]
    if di >= [bx.SizeX] then xor di,di

    if di <> [bx.OutX] then            ;Buffer not full
        es:[si] := al
        [bx.InX] := di
    else
        or [bx.Line_Status],20h        ;Overrun Error!
    endif

    STI

    if [bx.AutoX] = FALSE then ret

; Test if XOFF or XON
    ah := al                           ; Test if XOFF or XON
    and ah,7fh                         ; Use 7 low bits!

    if [bx.Ctrl_P] < 1 then
            if [bx.HostX] = FALSE then
                cmp ah,[BX.Xoff1C]
                je TurnOff
                if [bx.AltX] = TRUE then
                    cmp ah,[bx.Xoff2C]
                    je TurnOff
                endif
        endif
        cmp ah,[BX.Xon1C]
        je TurnOn
        cmp [bx.AltX],TRUE
        jne nochange
        cmp ah,[bx.Xon2C]
        je TurnOn
        jmp short nochange
    endif
    if = then                          ; if [bx.Ctrl_P] = 1 then
            if ah = 10h then
                [bx.Ctrl_P] := 2
                jmp short nochange
            endif
            cmp [bx.HostX],TRUE
            je TurnOn
            cmp ah,[bx.Xoff1C]
            je TurnOff
            jmp short nochange
    endif
    if [bx.Ctrl_P] = 2 then
            [bx.Ctrl_P] := 3
            jmp short nochange
    endif
    [bx.Ctrl_P] := 1
    jmp short nochange

TurnOn:
    [bx.HostX] := FALSE                ; Save new value
    call StartSender
    al := ' '
    jmp short updateX

TurnOff:
    [bx.HostX] := TRUE
    al := 'X'
UpdateX:
    if [bx.Show_X2] <> 0 then
        les di,dword ptr [bx.Show_X]
        es:[di] := al
    endif
NoChange:

; Test if buffer almost full

    dx := [bx.OutX]
    di := [bx.InX]
    inc di
    sub dx,di                                 ;InX
    if carry then add dx,[bx.SizeX]

; dx = Free space in buffer

    cmp dx,[bx.LimitX]
    jbe almost_full
    ret                                ;Buffer not full, early exit
Almost_Full:
    test [bx.Bfull],1                  ;Is our bit set?
    jnz Second_Limit                   ;Yes, check if past second limit
    or [bx.Bfull],1                    ;Set our bit
Stop_Rec:
    if [bx.UseTint] = TRUE then
            al := [bx.Xoff1C]
            ah := TRUE
            [bx.Send_T] := ax          ;Send before all others
            call StartSender
            ret                        ;Exit after XOFF sent
    endif
    call WaitTHRE
    al := [bx.Xoff1C]
    out dx,al
    ret

Second_Limit:
    shl dx,1
    cmp dx,[bx.LimitX]
    jbe Stop_Rec
    ret
ReadInt endp

WaitTHRE proc near
    mov dx,[bx].PortNr
    DXofs LineStatusReg
    repeat
        in al,dx
        ah := al
        and ah,1Eh
        or [bx.Line_Status],ah
    until al AND 20h true
    DXofs <TransmitReg - LineStatusReg>
    ret
WaitTHRE endp

SendByte proc near                     ; Sending WO TX-int
; INPUT   al : byte to send
; OUTPUT  ah : status
; REG'S   dx

    push ax
    call WaitTHRE
    pop ax

    ah := FALSE;
    if [bx.HostX] = FALSE then
        out dx,al
        ah := TRUE
    endif

    ret
SendByte EndP

SendInt Proc near
; Use buffered sending
; INPUT   al : byte to send
; OUTPUT  ah : status
; REG'S   dx,si,di,es,

    si := [bx.InT]
    lea di,[si+1]
    if di >= [bx.SizeT] then xor di,di

    ah := FALSE
    if di <> [bx.OutT] then
        es := [bx.T_Buf2]
        es:[si] := al

        [bx.InT] := di                 ;Update input pointer
        ah := TRUE
    endif

    call StartSender                   ;Restart if neccessary

    ret
SendInt endp

StartSender proc near
    push ax
    call SendNext
                                       ;Turn on TX int's again!
    InPort IntEnableReg
    or al,2
    out dx,al

    pop ax
    ret
StartSender endp

SendNoMore:
; Turn off TX int's when no more data
    InPort IntEnableReg
    and al,NOT 2
    out dx,al
    ret

SendNext Proc near                     ;SI
; INPUT
; OUTPUT
; REG'S   dx,ax,si,es

    if [bx.WaitTX] = FALSE then
        InPort LineStatusReg
        ah := al
        and ah,1Eh
        or [bx.Line_Status],ah

        if al AND 20h true then
            DXofs <TransmitReg - LineStatusReg>

            xor ax,ax
            xchg ax,[bx.Send_T]

            if ah <> FALSE then
                out dx,al
            elseif [bx.HostX] = FALSE then
                les si, dword ptr [bx.OutT]
                if si = [bx.InT] then jmp SendNoMore
                cld
                lods byte ptr es:[si]
                if si >= [bx.SizeT] then xor si,si
                [bx.OutT] := si
                out dx,al
            endif
        endif
    endif
    STI
    ret
SendNext endp

avail proc near
; INPUT
; OUTPUT  cx : bytes in input buffer
; REG'S   cx

    cx := [bx.InX]
    sub cx,[bx.OutX]
    if carry then add cx,[bx.sizeX]
    ret
avail endp

checkempty proc near                   ;Local proc for read and readblock
; INPUT
; OUTPUT
; REG'S   cx,ax
    if [bx.Bfull] and 1 true then
        call avail
        if cx <= [bx.LimitX] then
            and [bx.Bfull],254
            if zero then
                [bx.WaitTX] := TRUE    ;Allocate TX
                call WaitTHRE
                al := [bx.Xon1C]
                out dx,al
                [bx.WaitTX] := FALSE
            endif
        endif
    endif
    ret
checkempty endp

intro MACRO com
    bx := [bp+com]
    shl bx,1
    shl bx,1
    bx := rs_bufptr[bx-4]
ENDM

PasProc rs_readblock <bufs, buf, max, byts, byt, com> FAR
; REG'S   dx,cx,si,di,es,bx,ax

    intro com

    xor dx,dx                          ;zero bytes read
    call avail
    if cx > [bp].max then cx := [bp].max ;max bytes
    jcxz skipblock

    mov si,[bx.OutX]                   ;output index

    les di,[bp].buf                    ;buffer address
    cld                                ;les forover!

    dx := [bx.SizeX]                   ;Copy of size

  push ds
    ds := [bx.R_buf2]                  ;Segment of buffer
    push bx
    xor bx,bx                          ;bytes read

    repeat
        lodsb
        if si >= dx then xor si,si

        ah := al
        inc ah
        and ah,7fh
        if ah <= ' ' then
            if bx <> 0 then
                if si = 0 then si := dx
                dec si
                leave
            endif
            stosb
            inc bx
            leave
        endif

        stosb
        inc bx
    until loop

    dx := bx                           ;Save bytes read
    pop bx
  pop ds

    [bx.OutX] := si

skipblock:
    les di,[bp].byt
    es:[di] := dx                      ;bytes read in block
    call checkempty

PasRet

PasProc rs_busyread <chrs, chr, dones, done, com> FAR
    intro com

    si := [bx.OutX]

    ax := FALSE
    if si <> [bx.InX] then
        es := [bx.R_Buf2]
        cld
        lods byte ptr es:[si]
        if si >= [bx.SizeX] then xor si,si
        [bx.OutX] := si

        les di,[bp+chr]                ;ch
        stosb

        call checkempty

        al := TRUE
    endif

    les di,[bp.done]
    stosb

PasRet

PasProc rs_getchar <chrs, chr, com> FAR

    intro com

    si := [bx.OutX]

    xor ax,ax                          ; Return value

    if si <> [bx.InX] then
        es := [bx.R_Buf2]
        cld
        lods byte ptr es:[si]
        xor dx,dx
        ah := al
        inc ah
        and ah,7fh
        if ah > ' ' then
            if si >= [bx.SizeX] then xor si,si
            [bx.OutX] := si

            les di,[bp+chr]            ;ch
            stosb
            call checkempty
            dl := TRUE
        endif
        ax := dx
    endif
PasRet

PasProc rs_write <chr, dones, done, com> FAR
    intro com

    al := [bp+chr]

    if [bx.UseTInt] = TRUE then
        call SendInt
    else
        call SendByte
    endif

    les di,[bp.done]
    es:[di] := ah
PasRet

PasProc rs_writeblock <bufs, buf, len, byts, byt, com> FAR
    intro com

    cld                                ;Forward

    if [bx.UseTint] = FALSE then

        les si,[bp+buf]                ;buf
        cx := [bp+len]                 ;len
        dx := cx                       ;bytes sent
        jcxz skipwr

        push dx
        repeat
            lods byte ptr es:[si]
            call SendByte
            if ah = FALSE then leave
        until loop
        pop dx
        sub dx,cx
skipwr:
        ax := dx                       ;Bytes sent

    else                               ;Use TX int's

; Compute free room in TX buffer

        cx := [bx.OutT]
        di := [bx.InT]
        lea si,[di+1]
        ax := [bx.SizeT]

        sub cx,si                      ; OutT - (InT+1)
        if carry then add cx,ax

        if cx > [bp+len] then cx := [bp+len] ;Min(room,len)

        push cx                            ;Bytes sent

        jcxz skipwblock                    ;Request to send zero bytes!

        es := [bx.T_Buf2]
;       di := [bx.InT]                 ; OK from start

        push ds
        mov ds,[bp+bufs]
;******************* Her peker DS p bufferet, ikke p RS_Buffer!
        mov si,[bp+buf]                    ;buf

        sub ax,di                          ;Size - InT
        if ax < cx then                    ;Room on top of buffer?
            sub cx,ax                      ;Overflow part
            xchg cx,ax                     ;Room on top
            rep movsb                      ;First block
            xor di,di                      ;Continue from start of TX buffer
            cx := ax                       ;last part
        endif
        rep movsb                          ;Second block

        pop ds
;******************** N er DS:BX ok igjen!

        if di >= [bx.SizeT] then xor di,di
        [bx.InT] := di

skipwblock:
        pop ax                         ; # of bytes sent

    endif

    les di,[bp+done]
    stosw
    call StartSender

PasRet

PasProc rs_avail <com> FAR
    intro com
    call avail
    ax := cx
PasRet

PasProc rs_room <com> FAR              ;Room in output buffer
    intro com
    ax := [bx.OutT]
    dx := [bx.InT]

    inc dx
    sub ax,dx
    if carry then add ax,[bx].SizeT

PasRet

PasProc rs_enable <com> FAR
    intro com
    [bx.HostX] := FALSE
    mov al,0
    OutPort IntEnableReg
    al := [bx].Int_Mask
    out dx,al
    al := TRUE
    xchg al,[bx.WaitTX]
    if al = FALSE then
        call StartSender
        [bx.WaitTX] := FALSE
    endif
PasRet

PasProc rs_writefirst <chr, com> FAR
    intro com

    [bx.WaitTX] := TRUE                ;Allocate transmitter!
    call WaitTHRE
    al := [bp+chr]                     ;ch to send first
    out dx,al
    [bx.WaitTX] := FALSE
PasRet

CODE ENDS

    END
<<< crcs.pas >>>
{$R-,S-}

Unit CRCS;

Interface

FUNCTION CRC (VAR buf; len : WORD) : WORD;

FUNCTION ChkSum (VAR buf; len : WORD): WORD;

Implementation

TYPE CrcTabType = ARRAY [BYTE] OF WORD;

VAR CrcTab : CrcTabType;

FUNCTION CRC (VAR buf; len : WORD) : WORD;
BEGIN
Inline(
  $1E                    {push ds}
  /$1E                   {push ds}
  /$07                   {pop es}
  /$8D/$3E/>CRCTAB       {lea di,[>crctab]}
  /$C5/$76/<BUF          {lds si,[bp<buf]}
  /$8B/$4E/<LEN          {mov cx,[bp<len]}
  /$31/$D2               {xor dx,dx}
  /$E3/$13               {jcxz done}
  /$FC                   {cld}
                         {l1:}
  /$AC                   {lodsb}
  /$30/$D0               {xor al,dl}
  /$88/$C3               {mov bl,al}
  /$88/$F2               {mov dl,dh}
  /$30/$FF               {xor bh,bh}
  /$88/$FE               {mov dh,bh}
  /$D1/$E3               {shl bx,1}
  /$26/$33/$11           {es: xor dx,[di+bx]}
  /$E2/$EE               {loop l1}
                         {done:}
  /$89/$56/$FE           {mov [bp-2],dx}
  /$1F                   {pop ds}
);
END;

FUNCTION ChkSum (VAR buf; len : WORD): WORD;
BEGIN
InLine(
  $1E                    {  push ds}
  /$C5/$76/<BUF          {  lds si,[bp<buf]}
  /$8B/$4E/<LEN          {  mov cx,[bp<len]}
  /$31/$D2               {  xor dx,dx}
  /$89/$D0               {  mov ax,dx}
  /$FC                   {  cld}
  /$88/$CB               {  mov bl,cl}
  /$D1/$E9               {  shr cx,1}
  /$D1/$E9               {  shr cx,1}
  /$41                   {  inc cx}
  /$80/$E3/$03           {  and bl,3}
  /$74/$15               {  jz add0}
  /$80/$FB/$02           {  cmp bl,2}
  /$77/$07               {  ja add3}
  /$74/$08               {  je add2}
  /$EB/$09               {  jmp short add1}
                         {add4:}
  /$AC                   {  lodsb}
  /$01/$C2               {  add dx,ax}
                         {add3:}
  /$AC                   {  lodsb}
  /$01/$C2               {  add dx,ax}
                         {add2:}
  /$AC                   {  lodsb}
  /$01/$C2               {  add dx,ax}
                         {add1:}
  /$AC                   {  lodsb}
  /$01/$C2               {  add dx,ax}
                         {add0:}
  /$E2/$F2               {  loop add4}
                         {done:}
  /$89/$56/$FE           {  mov [bp-2],dx}
  /$1F                   {  pop ds}
);
END;

BEGIN
InLine(
   $1E                   {push ds}
  /$07                   {pop es}
  /$8D/$3E/>CRCTAB       {lea di,[>crctab]}
  /$BE/$08/$84           {mov si,$8408}
  /$FC                   {cld}
  /$31/$DB               {xor bx,bx}
  /$89/$D9               {mov cx,bx}
                         {l2:}
  /$89/$D8               {mov ax,bx}
  /$B1/$08               {mov cl,8}
                         {l3:}
  /$D1/$E8               {shr ax,1}
  /$73/$02               {jnc l4}
  /$31/$F0               {xor ax,si}
                         {l4:}
  /$E2/$F8               {loop l3}
  /$AB                   {stosw}
  /$FE/$C3               {inc bl}
  /$75/$EF               {jnz l2}
);
END.
<<< feltedit.pas >>>
{$R-,S-,D+,T+,F-,V+,B-}

Unit FeltEdit;

Interface

Uses Crt;

CONST
  ToUpper  = 1;
  ToLower  = 2;
  NoInput  = 4;

TYPE
  CharSet = SET OF CHAR;
  CharSetPtr = ^CharSet;
  JustType = (LeftJ,CenterJ,RightJ);
  FeltStr = STRING[12];
  PromptStr = STRING[30];
  FeltStrArray = ARRAY [0..255] OF FeltStr;
  FeltType = (CharT, StrT, EnumT, BoolT, ByteT, IntT, WordT, LongT);
  EditPtr = ^EditRecord;
  EditRecord = RECORD
                 x, y, len, xpos : BYTE;
                 just : JustType;
                 prompt : PromptStr;
                 CASE ftype : FeltType OF
                   CharT : (CharP : ^CHAR;
                            oksetC : CharSetPtr;
                            modeC : BYTE);
                   StrT  : (StrP : ^STRING;
                            oksetS : CharSetPtr;
                            modeS : BYTE);
                   EnumT,
                   BoolT : (EnumP : ^BYTE;
                            EnumAntall : BYTE;
                            EnumStr : ^FeltStrArray);
                   ByteT : (ByteP : ^BYTE;
                            ByteMin, ByteMax : LongInt);
                   IntT  : (IntP  : ^INTEGER;
                            IntMin, IntMax   : LongInt);
                   WordT : (WordP : ^WORD;
                            WordMin, WordMax : LongInt);
                   LongT : (LongP : ^LongInt;
                            LongMin, LongMax : LongInt);
               END;

CONST
  Eantall : WORD = 0;
  BoolStr : ARRAY [0..1] OF FeltStr = ('FALSE','TRUE');
  NumericSet : CharSet = ['0'..'9','.','+','-'];
  InsertMode : BOOLEAN = FALSE;
  LastRecord : WORD = 0;
  FeltAttr : BYTE =  14;
  EditAttr : BYTE = 112;

CONST
  EditChar : CHAR = #255;

FUNCTION EditStr(VAR str: String; VAR xpos: BYTE;
                 len, mode : BYTE; ok : CharSetPtr;just : JustType): BOOLEAN;

FUNCTION Pad(st:String;len : INTEGER): String;

FUNCTION Tstr(l : LongInt; len : INTEGER): String;

PROCEDURE ShowOne(VAR e : EditRecord);

PROCEDURE ShowAll;

PROCEDURE EditOne(VAR e : EditRecord);

PROCEDURE EditARecord(n : WORD);

FUNCTION UpCase(ch : CHAR): CHAR;

FUNCTION LoCase(ch : CHAR): CHAR;

PROCEDURE MakeStr(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : String; okp : Pointer; mode : BYTE);

PROCEDURE MakeChar(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : CHAR; okp : Pointer; mode : BYTE);

PROCEDURE MakeEnum(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v ; antall : BYTE; VAR enum_ar);

PROCEDURE MakeBool(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : BOOLEAN);

PROCEDURE MakeByte(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : BYTE; min, max : BYTE);

PROCEDURE MakeInt(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : INTEGER; min, max : INTEGER);

PROCEDURE MakeWord(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : WORD; min, max : WORD);

PROCEDURE MakeLong(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : LongInt; min, max : LongInt);

PROCEDURE EditAllRecords;

PROCEDURE EditVar(VAR v);

(**************************************************************************)

Implementation

VAR
  ERec : ARRAY [0..255] OF EditPtr;

CONST No_Upper : String[3] = '';
      No_Lower : String[3] = '';

FUNCTION UpCase(ch : CHAR): CHAR;
VAR p : INTEGER;
BEGIN
  IF (ch >= 'a') AND (ch <= 'z') THEN ch := CHAR(BYTE(ch)-32)
  ELSE BEGIN
    p := Pos(ch,No_Lower);
    IF p > 0 THEN ch := No_Upper[p];
  END;
  UpCase := ch;
END;

FUNCTION LoCase(ch : CHAR): CHAR;
VAR p : INTEGER;
BEGIN
  IF (ch >= 'A') AND (ch <= 'Z') THEN ch := CHAR(BYTE(ch)+32)
  ELSE BEGIN
    p := Pos(ch,No_Upper);
    IF p > 0 THEN ch := No_Lower[p];
  END;
  LoCase := ch;
END;

PROCEDURE MakeStr(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : String; okp : Pointer; mode : BYTE);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := StrT; xpos := 1; just := pjust;
    StrP := Addr(v);
    oksetS := okp;
    modeS := mode;
  END;
  Inc(EAntall);
END;

PROCEDURE MakeChar(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : CHAR; okp : Pointer; mode : BYTE);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := CharT; xpos := 1; just := pjust;
    CharP := Addr(v);
    oksetC := okp;
    modeC := mode;
  END;
  Inc(EAntall);
END;

PROCEDURE MakeEnum(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v ; antall : BYTE; VAR enum_ar);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := EnumT; xpos := 1; just := pjust;
    EnumP := Addr(v);
    EnumAntall := antall;
    EnumStr := Addr(enum_ar);
  END;
  Inc(EAntall);
END;

PROCEDURE MakeBool(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : BOOLEAN);
BEGIN
  MakeEnum(px,py,plen,pjust,prstr,v,2,BoolStr);
END;

PROCEDURE MakeByte(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : BYTE; min, max : BYTE);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := ByteT; xpos := 1; just := pjust;
    ByteP := Addr(v);
    ByteMin := min;
    ByteMax := max;
  END;
  Inc(EAntall);
END;

PROCEDURE MakeInt(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : INTEGER; min, max : INTEGER);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := IntT; xpos := 1; just := pjust;
    IntP := Addr(v);
    IntMin := min;
    IntMax := max;
  END;
  Inc(EAntall);
END;

PROCEDURE MakeWord(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : WORD; min, max : WORD);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := WordT; xpos := 1; just := pjust;
    WordP := Addr(v);
    WordMin := min;
    WordMax := max;
  END;
  Inc(EAntall);
END;

PROCEDURE MakeLong(px, py, plen : BYTE; pjust : JustType;
                  prstr : PromptStr; VAR v : LongInt; min, max : LongInt);
BEGIN
  New(ERec[EAntall]);

  WITH ERec[Eantall]^ DO BEGIN
    x := px; y := py; len := plen; prompt := prstr;
    ftype := LongT; xpos := 1; just := pjust;
    LongP := Addr(v);
    LongMin := min;
    LongMax := max;
  END;
  Inc(EAntall);
END;

FUNCTION Pad(st:String;len : INTEGER): String;
BEGIN
  IF len < 0 THEN BEGIN
    len := Lo(-len);
    WHILE len > Length(st) DO st := ' ' + st;
  END
  ELSE IF len > 0 THEN BEGIN
    len := Lo(len);
    WHILE len > Length(st) DO st := st + ' ';
  END;
  Pad := st;
END;

(*
FUNCTION Justify(st : String; len : BYTE; just : JustType): String;
VAR front : BOOLEAN;
BEGIN
  CASE just OF
    LeftJ   : Justify := Pad(st,len);
    CenterJ : BEGIN
                front := FALSE;
                WHILE Length(st) < len DO BEGIN
                  IF front THEN st := ' ' + st
                  ELSE st := st + ' ';
                  front := NOT front;
                END;
                Justify := st;
              END;
    RightJ  : Justify := Pad(st,-len);
  END;
END;
*)

FUNCTION Tstr(l : LongInt; len : INTEGER): String;
VAR st : String;
BEGIN
  Str(l:len,st);
  Tstr := st;
END;

FUNCTION Refresh(len: BYTE; just : JustType; st : String): INTEGER;
VAR front, back, offs : INTEGER;
BEGIN
  front := len - Length(st); IF front < 0 THEN front := 0;
  CASE just OF
    LeftJ   : BEGIN back := front; front := 0; END;
    RightJ  : back := 0;
    CenterJ : BEGIN back := (front+1) DIV 2; Dec(front,back); END;
  END;
  IF front > 0 THEN Write('':front);
  Write(st);
  IF back > 0 THEN Write('':back);
  Refresh := front;
END;

PROCEDURE ShowOne(VAR e : EditRecord);
VAR i : WORD;
    l : LongInt;
    attr : BYTE;
BEGIN
  attr := TextAttr;
  GotoXY(e.x,e.y);
  Write(e.prompt);
  TextAttr := FeltAttr;
  CASE e.ftype OF
    CharT : IF Refresh(e.len,e.just,e.CharP^) = 0 THEN ;
    StrT  : IF Refresh(e.len,e.just,e.StrP^) = 0 THEN ;
    BoolT,
    EnumT : IF Refresh(e.len,e.just,e.EnumStr^[e.EnumP^]) = 0 THEN ;
    ByteT : IF Refresh(e.len,e.just,Tstr(e.ByteP^,1)) = 0 THEN ;
    IntT  : IF Refresh(e.len,e.just,Tstr(e.IntP^,1)) = 0 THEN ;
    WordT : IF Refresh(e.len,e.just,Tstr(e.WordP^,1)) = 0 THEN ;
    LongT : IF Refresh(e.len,e.just,Tstr(e.LongP^,1)) = 0 THEN ;
  END;
  TextAttr := attr;
END;

PROCEDURE ShowAll;
VAR i : WORD;
BEGIN
  FOR i := 0 TO Eantall-1 DO
    ShowOne(ERec[i]^);
END;

FUNCTION EditStr(VAR str: String; VAR xpos: BYTE;
                 len, mode : BYTE; ok : CharSetPtr;just : JustType): BOOLEAN;
VAR sx, sy : BYTE;
    st : String;
    cok, ferdig, change, dirty : BOOLEAN;

PROCEDURE Del1; BEGIN Delete(st,xpos,1); Dirty := TRUE; END;

PROCEDURE RefreshStr;
BEGIN
  GotoXY(sx,sy);
  GotoXY(sx+xpos+Refresh(len,just,st)-1,sy);
  Dirty := FALSE;
END;

BEGIN
  EditStr := FALSE;
  sx := WhereX; sy := WhereY;
  st := str;
  dirty := TRUE;
  ferdig := FALSE;
  IF xpos > Length(str)+1 THEN xpos := 1;
  REPEAT
    IF len <= 1 THEN xpos := 1;
    {IF Dirty THEN }RefreshStr;

    EditChar := ReadKey;
    CASE EditChar OF
        #0 : BEGIN
               EditChar := ReadKey;
               CASE Ord(EditChar) OF
                 68 : BEGIN
                        st := str; RefreshStr; Exit;
                      END;
                 71 : BEGIN xpos := 1; END;
                 72,
                 80 : ferdig := TRUE;
                 75 : IF xpos > 1 THEN Dec(xpos);
                 77 : IF xpos <= Length(st) THEN Inc(xpos);
                 79 : BEGIN xpos := Length(st)+1; END;
                 82 : InsertMode := NOT InsertMode;
                 83 : Del1;
                $75 : st[0] := Chr(xpos-1);    {Ctrl-End}
                 ELSE
                   Exit;
               END;
             END;
        ^H : IF xpos > 1 THEN BEGIN
               Dec(xpos);
               Del1;
             END;
        ^M : ferdig := TRUE;
        ^[ : BEGIN
               change := st <> str;
               IF change THEN BEGIN st := str; xpos := 1; END;
               RefreshStr;
               IF NOT change THEN Exit;
             END;
        #0..#255 :
         BEGIN
           IF mode AND ToUpper <> 0 THEN EditChar := UpCase(EditChar)
           ELSE IF mode AND ToLower <> 0 THEN EditChar := LoCase(EditChar);

           cok := mode AND NoInput = 0;
           IF (ok <> NIL) AND cok THEN cok := EditChar IN ok^;

           IF cok THEN BEGIN
             IF InsertMode THEN BEGIN
               IF Length(st) < len THEN BEGIN
                 Insert(EditChar,st,xpos);
                 Inc(xpos);
               END;
             END
             ELSE BEGIN
               IF xpos <= len THEN BEGIN
                 IF xpos > Length(st) THEN
                   st := st + EditChar
                 ELSE
                   st[xpos] := EditChar;
                 Inc(xpos);
               END;
             END;
             Dirty := TRUE;
           END;
         END;
    END;
  UNTIL ferdig;
  str := st;
  EditStr := TRUE;
END;

FUNCTION EditNum(VAR e : EditRecord): BOOLEAN;
VAR feil, sx, sy : WORD;
    st : String;
    num : LongInt;
BEGIN
  EditNum:= FALSE;
  sx := WhereX; sy := WhereY;
  CASE e.ftype OF
    ByteT : num := e.ByteP^;
    IntT  : num := e.IntP^;
    WordT : num := e.WordP^;
    LongT : num := e.LongP^;
  END;

  REPEAT
    GotoXY(sx,sy);
    Str(num:1,st);
    e.xpos := 1;
    IF NOT EditStr(st,e.xpos,e.len,0,Addr(NumericSet),e.just) THEN Exit;
    Val(st,num,feil);
    IF feil = 0 THEN BEGIN
      feil := 1;
      IF num < e.LongMin THEN
        num := e.LongMin
      ELSE IF num > e.LongMax THEN
        num := e.LongMax
      ELSE
        feil := 0;
    END;
  UNTIL feil = 0;
  EditNum := TRUE;
  CASE e.ftype OF
    ByteT : e.ByteP^ := num;
    IntT  : e.IntP^  := num;
    WordT : e.WordP^ := num;
    LongT : e.LongP^ := num;
  END;
END;

FUNCTION EditEnum(VAR en; max : WORD; len : BYTE; just : JustType;
         VAR enstr : FeltStrArray): BOOLEAN;
VAR e : BYTE ABSOLUTE en;
    b : BYTE;
    sx, sy : WORD;
BEGIN
  b := e;
  sx := WhereX; sy := WhereY;
  EditEnum := TRUE;

  REPEAT
    GotoXY(sx,sy);
    IF Refresh(len,just,enstr[b]) = 0 THEN ;
    GotoXY(sx,sy);
    EditChar := ReadKey;
    CASE EditChar OF
      #0 :
        BEGIN
          EditChar := ReadKey;
          CASE Ord(EditChar) OF
            68 : BEGIN EditEnum := FALSE; Exit; END;
            71 : b := 0;
            72,
            80 : BEGIN e := b; Exit; END;
            75 : b := Succ(b) MOD max;
            77 : b := Pred(b+max) MOD max;
            79 : b := max-1;
            ELSE BEGIN
              e := b;
              Exit;
            END;
          END;
        END;
      ^M : BEGIN e := b; Exit; END;
      ^[ : IF e <> b THEN b := e
           ELSE BEGIN EditEnum := FALSE; Exit; END;
      ' ': b := Succ(b) MOD max;
    END;
  UNTIL FALSE;
END;

PROCEDURE EditOne(VAR e : EditRecord);
VAR res : BOOLEAN;
    attr : BYTE;
    st : String;
BEGIN
  attr := TextAttr;
  WITH e DO BEGIN
    GotoXY(x,y); Write(prompt);
    TextAttr := EditAttr;
    CASE ftype OF
      CharT : BEGIN
                st := CharP^;
                res := EditStr(st,xpos,len,modeC,oksetC,just);
                IF res AND (Length(st) = 1) THEN CharP^ := st[1];
              END;
      StrT  : res := EditStr(StrP^,xpos,len,modeS,oksetS,just);
      BoolT,
      EnumT : res := EditEnum(EnumP^,EnumAntall,len,just,EnumStr^);
      ByteT,
      IntT,
      WordT,
      LongT : res := EditNum(e);
    END;
  END;
  TextAttr := attr;
  ShowOne(e);
END;

PROCEDURE EditVar(VAR v);
VAR i : INTEGER;
BEGIN
  FOR i := 0 TO EAntall-1 DO BEGIN
    IF Addr(v) = Erec[i]^.StrP THEN EditOne(Erec[i]^);
    Inc(i);
  END;
END;

PROCEDURE EditARecord(n : WORD);
BEGIN
  IF n < Eantall THEN EditOne(Erec[n]^);
END;

PROCEDURE EditAllRecords;
BEGIN
  REPEAT
    EditARecord(LastRecord);
    Case EditChar OF
      #80 : LastRecord := Succ(LastRecord) MOD Eantall;
      #72 : LastRecord := Pred(LastRecord + Eantall) MOD Eantall;
    ELSE
      Exit;
    END;
  UNTIL EditChar = #27;
END;

END.
<<< fixattr.pas >>>
{$R-,S-}

Unit FixAttr;

Interface

Uses Crt;

Implementation

CONST Space : CHAR = ' ';

BEGIN
InLine(
   $B4/$03           {MOV    AH,03           }
  /$BB/$02/$00       {MOV    BX,0002         }
  /$CD/$10           {INT    10              }
  /$52               {PUSH   DX              }  {Save cursor pos}
  /$B4/$40           {MOV    AH,40           }
  /$B9/$01/$00       {MOV    CX,1            }
  /$BA/Space         {MOV    DX,OFFSET Space }
  /$CD/$21           {INT    21              }  {Write ' ' to stderr}
  /$B4/$02           {MOV    AH,02           }
  /$5A               {POP    DX              }
  /$CD/$10           {INT    10              }  {Restore cursor}
  /$B4/$08           {MOV    AH,08           }
  /$CD/$10           {INT    10              }  {Read DOS attr}
  /$88/$26/TextAttr);{MOV    [TextAttr],AH   }  {Update TextAttr}
END.
<<< kermit.inc >>>
(******************* KERMIT.INC ************************)

CONST
  MaxY = 25;
  LenModulo = 95;

CONST

    ErrorLevel : WORD = 0;
    SendDelay : WORD = 0;
    FileNameSet : SET OF CHAR =
      ['!','#'..')','-','.','0'..':','@'..'Z','\','^'..'z','~'];

VAR
    InnConvert, UtConvert : ARRAY [CHAR] OF CHAR;

VAR t2, MaxServer : TimerTableRec;           {Br vre global!}
    DTA : SearchRec;
    FTime : DateTime;
    MaxPrTick : WORD;

CONST
    KermitBufSize : WORD = $F000;

CONST
  Qrep        : BOOLEAN = TRUE;
  Q8Bit       : BOOLEAN = TRUE;
  ServerTimeOut : BOOLEAN = FALSE;
  RetryLimit  : BYTE =  10;
  YourTimeOut : BYTE =  15;
  SendTimeOut : BYTE =   5;
  MyPad      : BYTE = 0;
  MyPadChar  : CHAR = ^@;
  YourPad    : BYTE = 0;
  YourPadChar: CHAR = ^@;

TYPE
  CharArray = ARRAY [1..9040] OF CHAR;
  CarNum    = 0..222;
  IBM_Type  = 0..2;
  UnCarCh   = ' '..#254;
  PakkeCh   = '@'..'Z';
  PakkeType = RECORD
    TotLen: WORD;
    long  : BOOLEAN;
    plen  : CHAR;
    pnr   : UnCarCh;
    ptype : PakkeCh;
    CASE BOOLEAN OF
       TRUE : (plen1,
              plen2,
              hchk  : CHAR);
      FALSE : (pdata : CharArray);
    END;
  PakkeTypePtr = ^PakkeType;

TYPE
  PacketWindow = RECORD
    retry : WORD;
    dptr  : ^PakkeType;
    CASE BYTE OF
      0 : (acked, nacked : BOOLEAN);
      1 : (acknack : WORD);
    END;

  FilBuffer = ARRAY [0..$F000] OF CHAR;
  BufferPtr = ^FilBuffer;

VAR
  nr, i, n, ninn, nut : WORD;
  pw : ARRAY [0..63] OF PacketWindow;
  LongReply, DiskError : BOOLEAN;

  StopFile, AttrPakke : BOOLEAN;
  fil   : FILE;
  YourMaxLength, RetryNr, LastNr, PakkeNr,
  CheckType, FeilNr, PacketDelay : WORD;
  BufSize, BufCount, MaxRep : WORD;
  Bytes : LongInt;
  buffer : BufferPtr;
  BufPtr : ^CHAR;
  FileMax, TotalNr : LongInt;
  ShowTimeOut, EndOfFile : BOOLEAN;
  OriginalName, FileName, ErrorString, DownLoadPath,
  StatusString : String[80];
  RX_Pac, TX_Pac, Next_Pac : PakkeTypePtr;
  Next_Data_OK : BOOLEAN;
  RepQ, Bit8Q : CHAR;
  st : String;

TYPE DupHandleType = (RenameFile, OverWriteFile, SkipFile);

(**********************************************************************)
(*         Here are all variables that can be stored on disk:         *)
(**********************************************************************)

CONST
  Versjon : String[4] = 'V0.1';

  DupHandle : DupHandleType = RenameFile;
  OldDupHandle : DupHandleType = SkipFile;
  NewDupHandle : DupHandleType = OverWriteFile;

  CurBaud      : LongInt       =115200;
  CurBits      : WORD          =     8;
  CurStop      : WORD          =     1;
  CurParity    : ParityType    = No_Parity;
  CurComPort   : WORD          =     1;

  LongMaxLength: WORD          =  9020;
  WinSize      : WORD          =    31;
  MyTimeOut    : WORD          =    12;
  ServerTime   : WORD          =     0;

  LongPakke    : BOOLEAN       =  TRUE;
  WindowData   : BOOLEAN       = FALSE;
  TextFile     : BOOLEAN       = FALSE;
  IBM_Mode     : IBM_Type      =     0;
  BinaryData   : BOOLEAN       =  TRUE;
  FileCheck    : BYTE          =     2;

  MySOH        : CHAR          =    #1;
  YourSOH      : CHAR          =    #1;
  MyCR         : CHAR          =   #13;
  YourCR       : CHAR          =   #13;
  MyQCtrlChar  : CHAR          =   '#';
  YourQCtrlChar: CHAR          =   '#';
  Q8bitChar    : CHAR          =   '&';
  QrepChar     : CHAR          =   '~';

  KermitAttr   : BYTE          =     0;
  MenuAttr     : BYTE          =     0;
  FieldAttr    : BYTE          =     0;
  SaveEdit     : BYTE          =     0;
  DirVideo     : BOOLEAN       =  TRUE;

  Marker_Byte  : BYTE          =     0;

(**********************************************************************)
(*             Slutt p setup-variable!                               *)
(**********************************************************************)

  DupString : ARRAY[DupHandleType] OF FeltStr =
       ('Rename','OverWrite','Skip');
  BinText : ARRAY [BOOLEAN] OF FeltStr = ('BIN','TEXT');
  Std_IBM : ARRAY [IBM_Type] OF FeltStr = ('Std','I-E','IBM');
  ParityStr : ARRAY [ParityType] OF FeltStr =
      ('NONE','EVEN','ODD','MARK','SPACE');

PROCEDURE SplitFileName(fn : String; VAR drive,path,name,ext : String);
VAR e : WORD;
BEGIN
  e := Pos(':',fn);
  drive := '';
  IF e > 0 THEN BEGIN
    IF e = 2 THEN drive := Copy(fn,1,2);
    Delete(fn,1,e);
  END;

  e := Length(fn);
  ext := '';
  WHILE (e > 0) AND (fn[e] <> '.') AND (fn[e] <> '\') DO Dec(e);
  IF (e > 0) AND (fn[e] = '.') THEN BEGIN
    ext := Copy(fn,e,4);
    fn[0] := Chr(e-1);
  END;

  e := Length(fn);
  path := '';
  WHILE (e > 0) AND (fn[e] <> '\') DO Dec(e);
  IF e > 0 THEN path := Copy(fn,1,e);
  name := Copy(fn,e+1,8);
END;

FUNCTION Exist(fn : String): BOOLEAN;
VAR f : FILE;
    at : WORD;
BEGIN
  Assign(f,fn);
  GetFAttr(f,at);
  Exist := DosError = 0;
END;

PROCEDURE MoveW(VAR fra, til; len : WORD); BEGIN Move(fra,til,len*2); END;

PROCEDURE Bell; BEGIN Sound(1000); Delay(150); NoSound; END;

PROCEDURE ByteToDigits(by : BYTE; VAR buf);
VAR b : ARRAY [1..2] OF BYTE ABSOLUTE buf;
BEGIN
  b[1] := by DIV 10 + 48;
  b[2] := by MOD 10 + 48;
END;

FUNCTION Pad(st : String; len : INTEGER): String;
BEGIN
  WHILE len > Length(st) DO st := st + ' ';
  Pad := st;
END;

PROCEDURE SetCursor(mode : WORD);
BEGIN
Inline(
  $B4/$01                {mov ah,1}
  /$8B/$4E/<MODE         {mov cx,[bp<mode]}
  /$CD/$10               {int $10}
);
END;

PROCEDURE CursorOn;
BEGIN
  IF LastMode = 7 THEN
    SetCursor($C0D)
  ELSE
    SetCursor($607);
END;

PROCEDURE CursorOff;
BEGIN
  SetCursor($2000);
END;

PROCEDURE ClrAll; BEGIN ClrScr; END;

PROCEDURE ClrLast; BEGIN GotoXY(1,25); ClrEol; END;

PROCEDURE WriteStr(st : String);
BEGIN
  Write(st);
END;

PROCEDURE Error(msg : String);
BEGIN
  ClrLast;
  Write(msg,'  Hit Esc!');
  CursorOn;
  REPEAT UNTIL ReadKey = #27;
  CursorOff;
  ClrLast;
END;

(*
PROCEDURE ReadString(help : INTEGER; prompt : String; len : BYTE;
                     VAR st : String; VAR ok : BOOLEAN);
VAR xpos : BYTE;
BEGIN
  WriteStr(prompt);
  st := '';
  xpos := 1;
  ok := EditStr(st,xpos,len,0,NIL,LeftJ);
END;

PROCEDURE ReadString(help : INTEGER; prompt : String;
          maxlen : INTEGER;VAR st : String;VAR ok: BOOLEAN);
VAR key : WORD;
    ch : CHAR;
BEGIN
  ClrLast;
  CursorOn;
  Write(prompt);
  st := '';
  REPEAT
    key := ReadKey;
    IF key = $4400 THEN BEGIN
      st := '';
      ok := FALSE;
      CursorOff;
      Exit;
    END
    ELSE IF Lo(key) <> 0 THEN BEGIN
      ch := Chr(Lo(key));
      CASE ch OF
        ^H : IF Length(st) > 0 THEN BEGIN
               Dec(st[0]);
               Write(^H' '^H);
             END;
        ^M : BEGIN
               ok := TRUE;
               CursorOff;
               Exit;
             END;
        ELSE IF Length(st) < MaxLen THEN BEGIN
          st := st + ch;
          Write(ch);
        END;
      END;
    END;
  UNTIL FALSE;
END;

PROCEDURE ReadNum(help : INTEGER;prompt : String;min, max : WORD;
                  VAR svar : WORD);
VAR st : String;
    n, feil : INTEGER;
    ok : BOOLEAN;
BEGIN
  REPEAT
    ClrLast;
    ReadString(help,prompt,10,st,ok);
    IF st = '' THEN Exit;
    Val(st,n,feil);
  UNTIL (feil = 0) AND (n >= min) AND (n <= max);
  svar := n;
END;
*)

PROCEDURE ReadFileName(prompt : String; VAR fil : String);
VAR e : EditRecord;
    ok : CharSet;
BEGIN
  fil := '';
  ok := FileNameSet + ['*','?'];

  e.x := 1; e.y := 25; e.len := 53; e.prompt := prompt;
  e.ftype := StrT; e.xpos := 1; e.just := LeftJ;
  e.StrP := Addr(fil);
  e.okSetS := Addr(ok);
  e.ModeS := ToUpper;
  CursorOn;
  REPEAT
    EditOne(e);
  UNTIL EditChar IN [^M,#68,^[];
  CursorOff;
END;

FUNCTION Tstr(n, len : WORD): String;
VAR st : STRING[20];
BEGIN
  Str(n:len,st);
  Tstr := st;
END;

PROCEDURE StartTimerSek(VAR t : TimerTableRec; sek : WORD);
BEGIN
  t.count := sek *18;
  t.UserInt := FALSE;
  StartTimer(t);
END;

PROCEDURE BIOSKbd(help : INTEGER; expand : BOOLEAN; VAR ch : CHAR;
                  VAR scan : INTEGER);
BEGIN
  ch := ReadKey;
  IF ch = #0 THEN scan := Ord(ReadKey) ELSE scan := 2;
END;

FUNCTION KeyPress : BOOLEAN;
BEGIN
  KeyPress := KeyPressed;
END;

PROCEDURE ScrollWin(x0,y0,x1,y1,lines,attr : INTEGER);
VAR sx, sy : WORD;
BEGIN
  sx := WhereX; sy := WhereY;
  Window(x0,y0,x1,y1);
  GotoXY(1,1);
  IF lines = 0 THEN ClrScr
  ELSE IF lines > 0 THEN DelLine
  ELSE InsLine;
  Window(1,1,80,25);
  GotoXY(sx,sy);
END;

PROCEDURE GetF10;
BEGIN
  IF TotalBytes = 0 THEN Exit;
  ClrLast;
  WriteStr('File transfer completed!  Hit any key to continue ... ');
  IF ReadKey = #0 THEN IF ReadKey = #0 THEN;
END;

PROCEDURE UpperStr(VAR st : String);
VAR i : INTEGER;
BEGIN
  FOR i := 1 TO Length(st) DO st[i] := UpCase(st[i]);
END;

CONST MaxArgC = 2;
      MaxOptC = 1;

VAR InitFileName : STRING[80];
    ArgV : ARRAY [1..2] OF String[64];
    ArgC, OptC : BYTE;
    OptV : ARRAY [1..1] OF String[64];

PROCEDURE ParseCmd;
VAR i : INTEGER;
    st : String;
BEGIN
  ArgC := 0;
  OptC := 0;
  FOR i := 1 TO ParamCount DO BEGIN
    st := ParamStr(i);
    UpperStr(st);
    IF st[1] = '/' THEN BEGIN
      Inc(OptC);
      OptV[OptC] := st;
    END
    ELSE BEGIN
      Inc(ArgC);
      ArgV[ArgC] := st;
    END;
  END;
END;

PROCEDURE GetInitFileName;
VAR env_ptr : ^WORD;
    i : INTEGER;
    drive, path, name, ext, od, op, on, oe : String[80];
BEGIN
  ParseCmd;
  IF Hi(DosVersion) >= 3 THEN BEGIN
    env_ptr := Ptr(MemW[PrefixSeg:$2C],0);
    WHILE env_ptr^ <> 0 DO Inc(Word(env_ptr));
    Inc(Word(env_ptr),4);
    InitFileName := '';
    REPEAT
      InitFileName := InitFileName + CHAR(env_ptr^);
      Inc(Word(env_ptr));
    UNTIL CHAR(env_ptr^) = #0;
  END
  ELSE
    InitFileName := 'KERMIT';

  SplitFileName(InitFileName,drive,path,name,ext);
  ext := '.INI';

  IF (OptC >= 1) AND (Copy(OptV[1],1,3) = '/I=') THEN BEGIN
    SplitFileName(Copy(OptV[1],4,80),od,op,on,oe);
    IF (od <> '') OR (op <> '') THEN BEGIN
      drive := od;
      path := op;
    END;
    IF on <> '' THEN name := on;
    IF oe <> '' THEN ext := oe;
  END;
  InitFileName := drive+path+name+ext;
END;                                   {GetInitFileName}

PROCEDURE SaveParam;
VAR f : FILE;
BEGIN
  Assign(f,InitFileName);
  ReWrite(f,1);
  BlockWrite(f,Versjon,Ofs(Marker_Byte)-Ofs(Versjon));
  Close(f);
  IF IOresult <> 0 THEN Error('Save error!');
END;

FUNCTION GetParam : BOOLEAN;
VAR f : FILE;
    v : String[4];
    bytes : WORD;
    ok : BOOLEAN;
BEGIN
  GetParam := FALSE;
  GetInitFileName;

  IF Exist(InitFileName) THEN BEGIN
    Assign(f,InitFileName);
    Reset(f,1);
    v := '';
    BlockRead(f,v,SizeOf(v));
    bytes := Ofs(Marker_Byte)-Ofs(Versjon);
    ok := FALSE;
    IF (v <> Versjon) OR (FileSize(f) <> bytes) THEN Exit;
    Seek(f,0);
    BlockRead(f,Versjon,bytes);
    ok := IOresult = 0;
    Close(f);
    IF NOT ok OR (IOresult <> 0) THEN BEGIN
      Error('Get .INI error!');
      Exit;
    END;
    IF KermitAttr <> 0 THEN TextAttr := KermitAttr;
    IF SaveEdit <> 0 THEN EditAttr := SaveEdit;
  END;
  GetParam := TRUE;
END;

PROCEDURE StartLink;
BEGIN
  IF NOT DiskStopInt OR BinaryData THEN Exit;
  RS_Enable(CurComPort);
  RS_WriteFirst(^Q,CurComPort);
END;

PROCEDURE StopLink;
BEGIN
  IF DiskStopInt AND NOT BinaryData THEN RS_WriteFirst(^S,CurComPort);
END;

(******************** Statistics **********************)

FUNCTION DOS_Time : LongInt;
VAR h, m, s, s100 : WORD;
BEGIN
  GetTime(h,m,s,s100);
  DOS_Time := h * 36000 + m * 600 + s * 10 + (s100+5) DIV 10;
END;

PROCEDURE InitStat;
BEGIN
  TotalTime := DOS_Time; TotalBytes := 0; SendBytes := 0; ReceiveBytes := 0;
  FileNr := 0;
END;

PROCEDURE ShowStat;
VAR ch : CHAR;
    t  : REAL;
BEGIN
  IF TotalBytes+SendBytes+ReceiveBytes > 0 THEN BEGIN
    TotalTime := DOS_Time - TotalTime;
    Window(22,5,80,10);
    ClrScr;
    WriteLn('      Total bytes: ',TotalBytes);
    WriteLn('      Total files: ',FileNr);
    WriteLn('       Bytes sent: ',SendBytes);
    WriteLn('   Bytes received: ',ReceiveBytes);
    WriteLn('       Total time: ',TotalTime DIV 10,'.',TotalTime MOD 10);
    Write  ('   Effective Baud: ',TotalBytes * 100 DIV TotalTime);
    Window(1,1,80,25);
  END;
END;

TYPE
  KeyType = 0..40;
  KeySet = SET OF KeyType;

VAR OrigText, OrigMenu, OrigField, OrigEdit : BYTE;

PROCEDURE Init_Params;
VAR ok : BOOLEAN;
    temp : LongInt;
BEGIN
  RS_Init(CurBaud,CurBits,CurStop,CurParity,ok,CurComPort);

  temp := 115200 DIV ((115200 + (CurBaud Shr 1)) DIV CurBaud);
  IF temp <> CurBaud THEN BEGIN CurBaud := temp; ok := FALSE; END;

  MaxPrTick := CurBaud DIV 250;

  IF CurBaud > 30000 THEN BEGIN
    DiskStopInt := TRUE;
    WindowData := FALSE;
    RS_Buffer[CurComPort].AutoXoff := FALSE;
  END;

  IF IBM_Mode > 0 THEN BEGIN
    MySOH := '%';
    YourSOH := '%';
    BinaryData := FALSE;
  END;

  IF BinaryData THEN BEGIN
    CurBits := 8;
    CurParity := No_Parity;
    RS_Buffer[CurComPort].AutoXoff := FALSE;
  END;
{
    IF (CurBaud <= 2400) AND WindowData THEN
      RS_Start(RX_Int+TX_Int+RLS_int,CurComPort)
    ELSE
}
    RS_Start(RX_Int+RLS_int,CurComPort);

  YourQCtrlChar := MyQCtrlChar;
  YourSOH := MySOH;
  YourCR := MyCR;
END;

PROCEDURE Meny(VAR k : KeyType);
VAR
  temp : LongInt;
  st, keyset : String;
  ch : CHAR;
  OldPath : String[64];
  OldMenu, OldAttr : BYTE;
  dta : SearchRec;

PROCEDURE ShowMeny;
BEGIN
  IF MenuAttr = 0 THEN MenuAttr := OrigMenu;
  IF FieldAttr = 0 THEN FieldAttr := OrigField;
  FeltAttr := FieldAttr;
  IF KermitAttr = 0 THEN KermitAttr := OrigText;
  TextAttr := KermitAttr;
  IF SaveEdit = 0 THEN SaveEdit := OrigEdit;
  EditAttr := SaveEdit;

  ClrScr;

  GotoXY(22,3); Write(CpRt);

  GotoXY(34,14); WriteStr('Duplicate File Names');

  OldAttr := TextAttr;
  TextAttr := MenuAttr;
  GotoXY(1,25);
  WriteStr('F1-Send F2-Receive F3-Get F4-Server F5-Save   F7-DOS F8-Term F9-Logout F10-Exit');
  TextAttr := OldAttr;
  OldMenu := MenuAttr;
END;

BEGIN
  ShowMeny;
  CursorOn;

  REPEAT

    OldPath := DownLoadPath; OldAttr := KermitAttr;

    RS_Stop(CurComPort);

    ShowAll;
    EditAllRecords;                    {EditChar inneholder siste tast}

    IF (KermitAttr <> OldAttr) OR (FieldAttr <> FeltAttr) OR
       (MenuAttr <> OldMenu) THEN BEGIN
      ShowMeny;
      ShowAll;
    END;
    SaveEdit := EditAttr;

    Init_Params;

    IF DownLoadPath <> OldPath THEN BEGIN
      ChDir(DownLoadPath);
      IF IOresult = 0 THEN
        GetDir(0,DownLoadPath)
      ELSE BEGIN
        DownLoadPath := OldPath;
        ShowAll;
      END;
    END;
    DirectVideo := DirVideo;
  UNTIL EditChar IN [#59..#68];
  CursorOff;

  k := Ord(EditChar) - 58;
END;                                   {Meny}

<<< kermit.pas >>>
{$R-,S-,I-,D+,T+,F-,V-,B-,N-}
{ $R+,S+,I-,D+,T+,F-,V-,B-,N-}
{$M $2000,$9000,$18000}     {8k STACK, 36k-96k HEAP}

PROGRAM Kermits;

Uses MyDos, Crt, Timers, {Keyboard, }Async, Crcs, FeltEdit, FixAttr;

CONST
  CpRt : String[40] = 'KERMIT file transfer. V1.1a TMa, NH 1988';

  DiskStopInt : BOOLEAN = FALSE;

(**********************************************************************)
(*                                                                    *)
(*                   Start for Kermits egne procedures                *)
(*                                                                    *)
(**********************************************************************)

VAR TotalTime, TotalBytes, SendBytes, ReceiveBytes : LongInt;
    FileNr : WORD;

{$I KERMIT.INC}            {Kermit const, type, var and some proc's.}

PROCEDURE InitWindow;
VAR i : WORD;
    p : Pointer;
BEGIN
  FillChar(pw,SizeOf(pw),#0);
  ninn := PakkeNr; nut := PakkeNr;
  p := Next_Pac;

  FOR i := 0 TO 31 DO BEGIN
    pw[i].dptr    := p;
    pw[i+32].dptr := p;
    Inc(Word(p),108);                  {Room for 95 char + fudge factor}
  END;
  GotoXY(33,10); WriteStr('Window:');
  LongPakke := FALSE;
END;                                   { InitWindow }

PROCEDURE Warning(msg : String);
BEGIN
  ScrollWin(41,14,80,24,-1,KermitAttr);
  GotoXY(27,14); WriteStr('Last warning: '+msg);
END;

TYPE Retry_Code = (r_ok, r_keyboard, r_timeout, r_exit);
VAR r_code : Retry_Code;

FUNCTION Retry : Retry_Code;
VAR ch : CHAR;
    code : INTEGER;
    enable : BOOLEAN;
BEGIN
  r_code := r_ok;
  enable := FALSE;
  IF KeyPress THEN BEGIN
    BIOSKbd(-1,FALSE,ch,code);
    IF (ch = #0) THEN
      CASE code OF
        45 : enable := TRUE;
        59 : StopFile := TRUE;
        67 : BEGIN
               r_code := r_keyboard;
                  enable := TRUE;
             END;
        68 : r_code := r_exit;
      END;
  END
  ELSE IF NOT RunningTimer(t2) THEN BEGIN
    r_code := r_timeout;
    enable := TRUE;
  END;
  IF enable THEN BEGIN
    RS_Enable(CurComPort);
    StartLink;
  END;
  Retry := r_code;
END;                                   {Retry}

PROCEDURE SendLink(VAR buf; n : WORD);
LABEL Ferdig;
VAR d : CharArray ABSOLUTE buf;
    i, len : WORD;
    ok : BOOLEAN;
    ch : CHAR;
    dptr : ^CHAR;
BEGIN
  Inc(SendBytes,n+2);
  i := 10;
  IF SendTimeOut > 0 THEN
    i := SendTimeOut;
  StartTimerSek(t2,i);
  IF NOT WindowData THEN BEGIN
    WHILE (RS_Buffer[CurComPort].HostXoff OR
        NOT RS_Empty(CurComPort)) DO BEGIN
      RS_ClrBuffer(CurComPort);
      IF Retry <> r_ok THEN GOTO Ferdig;
    END;
    Delay(PacketDelay);             { Wait if neccessary! }
  END;
  REPEAT
    IF Retry <> r_ok THEN GOTO Ferdig;
    RS_Write(YourSOH,ok,CurComPort);
  UNTIL ok;
  IF CurBaud > 30000 THEN Delay(1);

  IF IBM_Mode = 1 THEN BEGIN
    REPEAT
      RS_BusyRead(ch,ok,CurComPort);
      IF NOT ok THEN
        IF Retry <> r_ok THEN GOTO Ferdig;
    UNTIL ok AND (ch = YourSOH);
    len := 1;
    i := 1;
    REPEAT
      IF len <= n THEN BEGIN
        RS_Write(d[len],ok,CurComPort);
        IF ok THEN BEGIN
          Inc(len);
          Delay(SendDelay);
        END;
      END;
      REPEAT
        RS_BusyRead(ch,ok,CurComPort);
        IF ok THEN BEGIN
          IF (d[i] = ch) OR (d[i] = ' ') THEN
            Inc(i);
        END
        ELSE
          IF Retry <> r_ok THEN GOTO Ferdig;
      UNTIL (len - i < 40) AND NOT ok;
    UNTIL (len > n) AND (i > n);
  END
  ELSE BEGIN
    dptr := Addr(d[1]);

    IF CurBaud > 30000 THEN BEGIN
      len := MaxPrTick;
      REPEAT
        IF len > n THEN len := n;
        RS_WriteBlock(dptr^,len,i,CurComPort);
        Dec(n,len);
        Inc(Word(dptr),len);
        Delay(1);
      UNTIL n = 0;
    END
    ELSE BEGIN
      REPEAT
        RS_WriteBlock(dptr^,n,i,CurComPort);
        IF Retry <> r_ok THEN GOTO Ferdig;
        Dec(n,i);
        Inc(Word(dptr),len);
      UNTIL n = 0;
    END;
  END;

  REPEAT
    RS_Write(YourCR,ok,CurComPort);
  UNTIL ok OR (Retry <> r_ok);

Ferdig:

END;                         { SendLink }

PROCEDURE GetLink(VAR buf; VAR n : WORD; max : WORD);
LABEL Ferdig, Restart_Packet;
VAR d : ARRAY [0..4000] OF CHAR ABSOLUTE buf;
    bytes, i, x : WORD;
    ch : CHAR;
    done : BOOLEAN;
    escape : STRING[10];
BEGIN
  StartTimerSek(t2,YourTimeOut);
  ch := ' ';

  REPEAT
    RS_BusyRead(ch,done,CurComPort);
    IF NOT done THEN
      IF Retry <> r_ok THEN GOTO Ferdig;
    Inc(ReceiveBytes,Ord(done));
  UNTIL (ch=MySOH);

  x := 3;

Restart_Packet:
  n := 0;

  d[0] := '~';                   { len   = 94 }
  d[3] := Chr(LenModulo+31);     { plen1 = 94/63 }
  d[4] := Chr(LenModulo+31);     { plen2 = 94/63 }

  REPEAT
    RS_ReadBlock(d[n],max - n,bytes,CurComPort);
    Inc(ReceiveBytes,bytes);
    IF bytes=0 THEN BEGIN
      IF d[0] > ' ' THEN BEGIN
        IF n > Ord(d[0]) - 32 THEN GOTO Ferdig;
      END
      ELSE
        IF n > (Ord(d[3]) - 32) * LenModulo + Ord(d[4]) - 32 THEN GOTO Ferdig;
      IF Retry <> r_ok THEN GOTO Ferdig;
{      Write_String(d[0],1,1,Byte_Stay,n,KermitAttr);    }
    END
    ELSE IF NOT BinaryData AND (d[n] < ' ') THEN BEGIN
      IF d[n] = MyCR THEN GOTO Ferdig;
      IF d[n] = MySOH THEN BEGIN
        GOTO Restart_Packet;
      END;
      IF (d[n] = ^[) AND (IBM_Mode > 0) THEN BEGIN
        escape[0] := #0;
        REPEAT                         { Read an Escape Seq's }
          RS_BusyRead(ch,done,CurComPort);
          IF NOT done THEN BEGIN
            IF Retry <> r_ok THEN GOTO Ferdig;
          END
          ELSE
            escape := escape + ch;
        UNTIL done AND (ch IN ['@'..'Z','a'..'z']);

        Dec(escape[0]);
        IF ch = 'H' THEN BEGIN
          WHILE x < 81 DO BEGIN
            Inc(x);
            d[n] := ' ';
            Inc(n);
          END;
          x := 1;
          ch := escape[Length(escape)];
          WHILE ch > '1' DO BEGIN
            Inc(x);
            d[n] := ' ';
            Inc(n);
            Dec(ch);
          END;
        END;
      END;
      { Ignore other control characters ! }
    END
    ELSE BEGIN
      Inc(n,bytes);
      IF IBM_Mode > 0 THEN BEGIN
        Inc(x,bytes);
        IF x > 81 THEN x := 81;
      END;
      IF (n >= max) THEN GOTO Ferdig;
    END;
  UNTIL FALSE;
  Ferdig:
END;                         { GetLink }

FUNCTION CheckSum(VAR buf; n, CheckType : WORD): WORD;
BEGIN
  IF CheckType <= 2 THEN BEGIN
    n := ChkSum(buf,n);
    IF CheckType = 1 THEN
      CheckSum := (n + Lo(n) Shr 6) AND 63
    ELSE
      CheckSum := n AND $FFF;
  END
  ELSE { CRC }
    CheckSum := CRC(buf,n);
END;                         { CheckSum }

PROCEDURE SendPakkeT(VAR T : PakkeType);
VAR s : WORD;
BEGIN
  IF T.long THEN BEGIN
    T.plen := ' ';
    T.plen1 := Chr(32 + (T.TotLen - 1) DIV LenModulo);
    T.plen2 := Chr(32 + ((T.TotLen - 1) MOD LenModulo));
    s := CheckSum(T.plen,5,1);
    T.hchk := Chr(32 + s);
  END
  ELSE BEGIN
    IF (T.TotLen > 95) OR (T.TotLen < 4) THEN BEGIN
      WriteLn('Gal lengde: ',T.TotLen);
      Exit;
    END;
    T.plen := Chr(31 + T.TotLen);
  END;
  s := CheckSum(T.plen,T.TotLen-CheckType,CheckType);
  IF CheckType >= 2 THEN BEGIN
    IF CheckType = 3 THEN
      T.pdata[T.TotLen-5] := Chr(32 + (s Shr 12));
    T.pdata[T.TotLen-4] := Chr(32 + ((s Shr 6) AND 63));
  END;
  T.pdata[T.TotLen-3] := Chr(32 + (s AND 63));
  SendLink(T.plen,T.TotLen);
END;                         { SendPakkeT }

PROCEDURE SendPakke;
BEGIN
  SendPakkeT(TX_Pac^);
END;

PROCEDURE MakePakke(VAR p : PakkeType; nr : CarNum;
                    typ : PakkeCh; data : String);
BEGIN
  p.pnr := Chr(32 + nr);
  p.ptype := typ;
  p.TotLen := Length(data) + 3 + CheckType;
  p.plen := Chr(31 + p.TotLen);
  p.long := FALSE;
  Move(data[1],p.pdata,Length(data));
END;                         { MakePakke }

FUNCTION TestPakke(VAR p : PakkeType): BOOLEAN;
VAR chk, c : WORD;
BEGIN
  TestPakke := FALSE;
  IF p.TotLen <= 2 + CheckType THEN BEGIN
    IF p.TotLen > 0 THEN
      Warning('Too short packet!')
    ELSE IF (p.TotLen = 0) AND ShowTimeOut THEN
      Warning('TimeOut!');
    Exit;
  END;
  IF (p.ptype < 'A') OR (p.ptype > 'Z') THEN BEGIN
    Warning('Error in packet type!');
    Exit;
  END;
  IF p.plen > ' ' THEN BEGIN
    chk := Ord(p.plen) - 32;
    p.long := FALSE;
  END
  ELSE BEGIN
    chk := CheckSum(p.plen,5,1);
    IF chk <> Ord(p.hchk)-32 THEN BEGIN
      Warning('Error in header checksum!');
      Exit;
    END;
    chk := (Ord(p.plen1) - 32) * LenModulo + Ord(p.plen2) - 32;
    p.long := TRUE;
  END;
  IF chk >= p.TotLen THEN BEGIN
    Warning('Len error: '+Tstr(chk-p.TotLen-1,1));
    Exit;
  END;
  p.TotLen := Succ(chk);
  IF Ord(p.pnr) - 32 > 63 THEN Exit;
  chk := CheckSum(p.plen,p.TotLen - CheckType,CheckType);
  c := Ord(p.pdata[p.TotLen-3]) - 32;
  IF CheckType >= 2 THEN BEGIN
    Inc(c,(Ord(p.pdata[p.TotLen-4]) - 32) Shl 6);
    IF CheckType = 3 THEN
      Inc(c,(Ord(p.pdata[p.TotLen-5]) - 32) Shl 12);
  END;
  IF c = chk THEN
    TestPakke := TRUE
  ELSE
    Warning('CHK err: Calc='+Tstr(chk,1)+', Rec='+Tstr(c,1));
END;                                   {TestPakke}

PROCEDURE GetFast(VAR p; VAR len : WORD; max : WORD);
LABEL Avbryt;
VAR by : BYTE;
    ch : CHAR;
    ok : BOOLEAN;
    dptr : ^BYTE;
    md, dend, bytes, receive, status : WORD;
    count : WORD;
BEGIN
  StartTimerSek(t2,YourTimeOut);
  dptr := Addr(p);
  dend := Word(dptr) + max;

  receive := RS_Buffer[CurComPort].ICadr;
  status := receive + 5;

  count := MaxPrTick;
  ch := #255;
  REPEAT
    IF (Retry <> r_ok) OR NOT RunningTimer(t2) THEN GOTO Avbryt;
    RS_BusyRead(ch,ok,CurComPort);
    Inc(ReceiveBytes,Ord(ok));
  UNTIL ch = MySOH;

{  RS_Set_TX_Int(0,CurComPort);}
  InLine($FA);                         {CLI}

  Port[receive+1] := 0;                {Turn off all Serial int's}

  md := 2000;                          {Wait up to 8 ms for first char.}
  REPEAT
    repeat
      Dec(md);
      if md = 0 then goto avbryt;
    until Odd(Port[status]);           {Received data available}

    dptr^ := Port[receive];
    Inc(Word(dptr));
    md := 200;                         { >1 ms delay between two chars}
    Dec(count);
    IF count = 0 THEN BEGIN
      InLine($FB);
        md := 2000;
        count := MaxPrTick;
      InLine($FA);
    END;
  UNTIL Word(dptr) >= dend;

Avbryt:
  InLine($FB);
  Port[receive+1] := RX_int+RLS_int;   {Turn off all Serial int's}

  len := Word(dptr) - Ofs(p);
  Inc(ReceiveBytes,len);
END;

PROCEDURE GetPakke;
VAR max : WORD;
BEGIN
  IF LongPakke THEN max := 9030 ELSE max := 95;
  IF (CurBaud > 30000) THEN
    GetFast(RX_Pac^.plen,RX_Pac^.TotLen,max)
  ELSE
    GetLink(RX_Pac^.plen,RX_Pac^.TotLen,max);
  IF r_code = r_ok THEN BEGIN
    IF NOT TestPakke(RX_Pac^) THEN BEGIN
      MakePakke(RX_Pac^,PakkeNr,'T','P');
    END;
  END
  ELSE IF r_code = r_keyboard THEN
    MakePakke(RX_Pac^,PakkeNr,'T','K')
  ELSE IF r_code = r_timeout THEN
    MakePakke(RX_Pac^,PakkeNr,'T','T')
  ELSE IF r_code = r_exit THEN
    MakePakke(RX_Pac^,PakkeNr,'E','F10')
  ELSE BEGIN
    Warning('r_code error!');
    MakePakke(RX_Pac^,PakkeNr,'T','R');
  END;
END;                         { GetPakke }

PROCEDURE Extract(VAR st : String);
VAR i, l : WORD;
BEGIN
  i := 1;
  IF RX_Pac^.long THEN i := 4;

  l := RX_Pac^.TotLen - i - 2 - CheckType;
  IF l >= SizeOf(st) THEN l := SizeOf(st) - 1;
  st[0] := Chr(l);
  Move(RX_Pac^.pdata[i],st[1],l);
END;                         { Extract }

PROCEDURE DumpPointers;
CONST NackCh : ARRAY [0..10] OF CHAR = '-123456789A';
VAR n, i : WORD;
BEGIN
  st[0] := #31;
  FillChar(st[1],31,' ');
  n := nut;
  FOR i := 1 TO (ninn-nut) AND 63 DO BEGIN
    st[i] := NackCh[pw[n].retry];
    n := Succ(n) AND 63;
  END;
  GotoXY(41,10); WriteStr(st);
END;

PROCEDURE MakeInfoScreen(s : String);
BEGIN
  ClrAll;
  ClrLast;
  GotoXY(30,6); WriteStr('File name:');
  GotoXY(22,7); WriteStr('Bytes transferred:');
  GotoXY(30,9); WriteStr(s);
  GotoXY(22,11); WriteStr('Number of packets:');
  GotoXY(22,12); WriteStr('Number of retries:');
  GotoXY(29,13); WriteStr('Last error:');
  GotoXY(1,25); WriteStr('Kermit:  F1=Cancel File');

  GotoXY(61,MaxY);  WriteStr('F9=Retry  F10=Abort');
END;  { MakeInfoScreen }

PROCEDURE WriteFileName;
BEGIN
  GotoXY(41,6);
  IF OriginalName <> FileName THEN
    WriteStr(Pad(OriginalName + ' as '+FileName,40))
  ELSE
    WriteStr(Pad(FileName,40));
END;

PROCEDURE WriteBytes;
BEGIN
  GotoXY(41,7); Write(Bytes);
END;

PROCEDURE WriteFileSize;
BEGIN
  GotoXY(30,8); Write('File size: ',FileMax); ClrEol;
END;  { WriteSize }

PROCEDURE WriteStatus;
BEGIN
  GotoXY(41,9); WriteStr(StatusString); ClrEol;
END;

PROCEDURE WriteTotalNr;
BEGIN
  Inc(TotalNr);
  GotoXY(41,11); Write(TotalNr);
END;  { WriteTotalNr }

PROCEDURE WriteFeilNr;
BEGIN
  Inc(FeilNr);              {Auto-Increment FeilNr}
  GotoXY(41,12); Write(FeilNr);
END;

PROCEDURE WriteError;
BEGIN
  GotoXY(41,13); WriteStr(Pad(ErrorString,57));
  RS_ClrBuffer(CurComPort);
END;

PROCEDURE ZeroBytes;
BEGIN
  Bytes := 0;
  GotoXY(41,7); ClrEol;
END;

PROCEDURE AddBytes(n : WORD);
BEGIN
  Bytes := Bytes + n;
  WriteBytes;
END;                                   {AddBytes}

PROCEDURE SendPacket(PakkeNr : CarNum; typ : PakkeCh; st : String);
BEGIN
  MakePakke(TX_Pac^, pakkenr, typ, st);
  SendPakke;
END;                         { SendPacket }

PROCEDURE SendAbort(s : String);
BEGIN
  ErrorString := s;
  WriteError;
  SendPacket(PakkeNr,'E',s);
END;                         { SendAbort }

PROCEDURE MakeNextData; FORWARD;

TYPE KermitState = (Abort, Complete, SendInit, SendName,
                    SendAttr, SendData, SendEOF,
                    SendEnd, WaitInit, WaitName, WaitData, TimeOut);

PROCEDURE SendAndGet(VAR s : KermitState; OkState : KermitState;
                         data : BOOLEAN);
VAR Ferdig : BOOLEAN;
    nr : WORD;
BEGIN
  RetryNr := 0; Ferdig := FALSE;
  REPEAT
    SendPakke;
    IF data THEN
      MakeNextData;
    GetPakke;
    WITH RX_Pac^ DO BEGIN
      nr := Ord(pnr) - 32;
      IF ((ptype = 'Y') AND (nr = PakkeNr)) OR
         ((ptype = 'N')) AND (nr = Succ(PakkeNr) AND 63) THEN BEGIN
        Ferdig := TRUE;
        s := OkState;
        PakkeNr := Succ(PakkeNr) AND 63;
        WriteTotalNr;
      END
      ELSE IF (ptype IN ['N','T']) OR (ptype = TX_Pac^.ptype) THEN BEGIN
        Inc(RetryNr);
        WriteFeilNr;
        Warning(ptype+'-packet received!');
        IF RetryNr >= RetryLimit THEN BEGIN
          Ferdig := TRUE;
          s := Abort;
          SendAbort('Too many retries!');
        END;
      END
      ELSE IF ptype = 'E' THEN BEGIN
        Ferdig := TRUE;
        s := Abort;
        Extract(ErrorString);
        WriteError;
      END
      ELSE IF (nr = PakkeNr) OR (nr = Succ(PakkeNr) AND 63) THEN BEGIN
        SendAbort('Wrong packet type: '+ptype);
        ptype := 'E';
        Ferdig := TRUE;
        s := Abort;
      END;
    END;
  UNTIL Ferdig;
  IF s = Abort THEN ErrorLevel := 2;
END;                         { SendAndGet }

CONST
      Reserved1Bit = 32;
      Reserved2Bit = 16;
      A_PacketBit  =  8;
      WindowBit    =  4;
      LongPakkeBit =  2;

      BinaryDataBit= 32;

PROCEDURE MakeInitPacket(Ptyp : PakkeCh);
VAR s : String;
    b : BYTE;
BEGIN
  s := Pad('',14);
  IF LongMaxLength < 95 THEN BEGIN
    s[1] := Chr(32 + (LongMaxLength));
    LongPakke := FALSE;
  END
  ELSE
    s[1] := '~';
  IF Ptyp = 'Y' THEN
    IF Abs(YourTimeOut-MyTimeOut) < 2 THEN
      MyTimeOut := YourTimeOut - 2
  ELSE
    AttrPakke := TRUE;
  s[2] := Chr(32 + (MyTimeOut));
  s[3] := Chr(32 + (MyPad));
  s[4] := Chr(64 XOR Ord(MyPadChar));
  s[5] := Chr(32 + (Ord(MyCR)));
  s[6] := MyQCtrlChar;
  s[7] := Q8BitChar;
  IF (Ptyp = 'S') AND (CurBits=8) THEN
    s[7] := 'Y'
  ELSE IF (Ptyp = 'Y') AND NOT Q8Bit THEN
    s[7] := 'N';
  s[8] := Chr(FileCheck+48);
  s[9] := QrepChar;

  b := A_PacketBit + 1;
  IF LongPakke THEN BEGIN
    b := b OR LongPakkeBit;
    s[13] := Chr(32 + (LongMaxLength DIV LenModulo));
    s[14] := Chr(32 + (LongMaxLength MOD LenModulo));
  END;
  IF WindowData THEN BEGIN
    b := b OR WindowBit;
    s[12] := Chr(32 + WinSize);
  END;
  s[10] := Chr(b+32);
  b := 0;
  IF BinaryData THEN b := BinaryDataBit;
  s[11] := Chr(b+32);
  MakePakke(TX_Pac^, 0, ptyp, s);
END;                         { MakeInitPacket }

PROCEDURE TolkInitPacket;
VAR c, l, w, a2 : INTEGER;
    s    : String;
BEGIN
  Extract(s);
  s := Pad(s,30);
  YourMaxLength := Ord(s[1]) - 32;
  IF s[2] > ' ' THEN YourTimeOut := -32 + Ord(s[2]);
  IF RX_Pac^.ptype <> 'Y' THEN
    IF Abs(YourTimeOut-MyTimeOut) < 2 THEN
      MyTimeOut := YourTimeOut - 2;
  YourPad := -32 + Ord(s[3]);
  YourPadChar := Chr(64 XOR Ord(s[4]));
  IF s[5] > ' ' THEN YourCR := Chr(Ord(s[5]) - 32);
  IF s[6] > ' ' THEN YourQCtrlChar := s[6];
  IF s[7] IN ['!'..'>',#96..'~'] THEN BEGIN
    Q8bitChar := s[7];
    Q8bit := TRUE;
  END
  ELSE Q8bit := (s[7] = 'Y') AND (CurBits=7);
  CASE s[8] OF
    '2' : FileCheck := 2;
    '3' : FileCheck := 3;
    ELSE
      FileCheck := 1;
  END;
  Qrep := s[9] = QrepChar;
  IF Qrep THEN maxrep := 94 ELSE maxrep := 1;
  c := Ord(s[10]) - 32;
  a2 := 0;
  IF Odd(c) THEN a2 := Ord(s[11]) - 32;
  l := 10;
  WHILE Odd(Ord(s[l])) DO Inc(l);         {skip all other attribute bits}
  WindowData := WindowData AND (c AND WindowBit <> 0);
  IF WindowData THEN BEGIN
    WinSize := Ord(s[l+1]) - 32;      {We can accept any size up to 31}
    WindowData := WinSize > 1;
  END;
  LongPakke := LongPakke AND (c AND LongPakkeBit <> 0) AND NOT WindowData;
  AttrPakke := AttrPakke AND (c AND A_PacketBit <> 0);
  IF LongPakke THEN BEGIN
    l := (Ord(s[l+2]) - 32) * LenModulo + Ord(s[l+3]) - 32;
    IF l = 0 THEN
      LongMaxLength := 500
    ELSE IF l < LongMaxLength THEN
      LongMaxLength := l;
  END;
  BinaryData := BinaryData AND (a2 AND BinaryDataBit <> 0);
END;                                   {TolkInitPacket}

PROCEDURE XmitAttr(VAR state : KermitState);
VAR siz : String[12];
BEGIN
  UnPackTime(DTA.Time,FTime);

  Str((FileMax + 1023) DIV 1024:1,st);
  Str(FileMax:1,siz);
  st := '#/861124 14:56:30!'+Chr(32+Length(st))+
        st+'1'+Chr(32+Length(siz))+siz;

  ByteToDigits(FTime.year MOD 100,st[3]);
  ByteToDigits(FTime.month,st[5]);
  ByteToDigits(FTime.day,st[7]);
  ByteToDigits(FTime.hour,st[10]);
  ByteToDigits(FTime.min,st[13]);
  ByteToDigits(FTime.sec,st[16]);

  MakePakke(TX_Pac^, PakkeNr,'A',st);
  SendAndGet(state,SendData,FALSE);
  IF (state = SendData) THEN BEGIN
    Extract(st);
    IF (Length(st) > 0) AND (st[1] = 'N') THEN BEGIN
      StopFile := TRUE;
      state := SendEOF;
    END;
  END;
END;

PROCEDURE XmitEOF(VAR s : KermitState);
BEGIN
  Inc(TotalBytes,FilePos(fil));
  Close(fil);
{  Debug('Enter XmitEOF'); }
  IF StopFile THEN BEGIN
    MakePakke(TX_Pac^, PakkeNr,'Z','D');
    Warning(FileName+' discarded!');
  END
  ELSE
    MakePakke(TX_Pac^, PakkeNr,'Z','');
  SendAndGet(s,SendName,FALSE);
END;                         { XmitEOF }

PROCEDURE XmitEnd(VAR s : KermitState);
BEGIN
  MakePakke(TX_Pac^, PakkeNr,'B','');
  SendAndGet(s,Complete,FALSE);
END;                         { XmitEnd }

TYPE STRING3 = RECORD
                 CASE BOOLEAN OF
                   FALSE: (st : STRING[3]);
                   TRUE:  (p  : Pointer);
               END;

VAR CodeTab : ARRAY [CHAR] OF STRING3;

PROCEDURE MakeCodeTab;
TYPE Str3Ptr = ^String3;
VAR lch, ch : CHAR;
    b       : WORD;
    CodePtr : Str3Ptr;
    st      : ARRAY [0..3] OF CHAR;
    len     : BYTE ABSOLUTE st;
BEGIN
  CodePtr := @CodeTab;
  FOR b := 0 TO 255 DO BEGIN
    ch := Chr(b);
    lch := Chr(b AND 127);
    len := 0;
    IF (ch > #127) AND Q8Bit THEN BEGIN
      len := 1;
      st[1] := Q8BitChar;
      ch := lch;
    END;
    IF (Succ(b) AND 127) <= 32 THEN BEGIN
      Inc(len);
      st[len] := YourQCtrlChar;
      ch := Chr(64 XOR Ord(ch));
    END
    ELSE IF ((lch = Q8BitChar) AND Q8Bit) OR ((lch = QrepChar) AND Qrep) OR
       (lch = YourQCtrlChar) THEN BEGIN
      Inc(len);
      st[len] := YourQCtrlChar;
    END;
    Inc(len);
    st[len] := ch;

    CodePtr^ := String3(st);
    Inc(Word(CodePtr),SizeOf(String3));
  END;
END;                                   {MakeCodeTab}

PROCEDURE MakeDataPac(VAR p : PakkeType);
LABEL Avbryt;
VAR ch : CHAR;
    st : STRING[3];
    pst : Pointer ABSOLUTE st;
    n, max, databytes : WORD;
    dptr : ^CHAR;
BEGIN
  p.ptype := 'D';
  p.pnr := Chr(32 + PakkeNr);
  dptr := @p.pdata[1];
  IF LongPakke THEN BEGIN
    Inc(Word(dptr),3);                 {Skip over long header}
    max := LongMaxLength - 7 - CheckType;
    p.long := TRUE;
  END
  ELSE BEGIN
    max := YourMaxLength - 7 - CheckType;
    p.long := FALSE;
  END;

  databytes := 0;
  IF EndOfFile THEN GOTO Avbryt;

  IF BinaryData THEN BEGIN
    Inc(max,4);
    IF BufCount < max THEN BEGIN
      IF BufCount > 0 THEN BEGIN
        Move(BufPtr^,dptr^,BufCount);
        Inc(Word(dptr),BufCount);
        Inc(databytes,BufCount);
        Dec(max,BufCount);
      END;

      BlockRead(fil,buffer^,BufSize,BufCount);

      IF (IOresult <> 0) OR (BufCount = 0) THEN BEGIN
        EndOfFile := TRUE;
        GOTO Avbryt;
      END;
      BufferPtr(BufPtr) := Buffer;
      IF max > BufCount THEN max := BufCount;
    END;
    Move(BufPtr^,dptr^,max);
    Inc(Word(BufPtr),max);
    Dec(BufCount,max);
    Inc(Word(dptr),max);
    Inc(databytes,max);
    GOTO Avbryt;
  END;

  max := Ofs(p.pdata[max]);

  REPEAT
    IF BufCount = 0 THEN BEGIN
      StopLink;
      BlockRead(fil,buffer^,BufSize,BufCount);
      StartLink;
      IF (IOresult <> 0) OR (BufCount = 0 ) THEN BEGIN
        EndOfFile := TRUE;
        GOTO AvBryt;
      END;
      BufferPtr(BufPtr) := Buffer;
      buffer^[BufCount] := Chr(NOT Ord(buffer^[BufCount - 1]));  {guard!}
    END;
    ch := BufPtr^;
    n := 1;
    Inc(Word(BufPtr));
    Dec(BufCount);
    WHILE (ch = BufPtr^) AND (n < MaxRep) DO BEGIN
      Inc(n);
      Inc(Word(BufPtr));
      Dec(BufCount);
    END;
    IF TextFile THEN BEGIN
      ch := UtConvert[ch];
      IF ch = ^Z THEN BEGIN
        EndOfFile := TRUE;
        Goto Avbryt;
      END;
    END;
    Inc(databytes,n);
    pst := CodeTab[ch].p;   {st := CodeTab[ch].st;}
    IF (n = 2) AND (st[0] = #1) THEN BEGIN
      dptr^ := st[1];
      Inc(Word(dptr));
      dptr^ := st[1];  {repeat 2 times!}
      Inc(Word(dptr));
    END
    ELSE BEGIN
      IF n >= 2 THEN BEGIN
        dptr^ := QrepChar;
        Inc(Word(dptr));
        dptr^ := Chr(n+32);
        Inc(WORD(dptr));
      END;

      dptr^ := st[1];
      Inc(WORD(dptr));
      IF st[0] > #1 THEN BEGIN
        dptr^ := st[2];
        Inc(WORD(dptr));
        IF st[0] > #2 THEN BEGIN
          dptr^ := st[3];
          Inc(WORD(dptr));
        END;
      END;
    END;
  UNTIL Word(dptr) >= max;
Avbryt:
  IF databytes = 0 THEN
    p.TotLen := 0
  ELSE BEGIN
    AddBytes(databytes);
    p.TotLen := Word(dptr) - Ofs(p.plen) + CheckType;
  END;
END;                                   {MakeDataPac}

PROCEDURE MakeNextData;
BEGIN
  IF NOT Next_Data_OK AND (CurBaud < 30000) THEN BEGIN
    MakeDataPac(Next_Pac^);
    Next_Data_OK := TRUE;
  END;
END;

PROCEDURE MakeData;
VAR temp : PakkeTypePtr;
BEGIN
  IF Next_Data_OK THEN BEGIN
    temp := TX_Pac;
    TX_Pac := Next_Pac;
    Next_Pac := temp;

    TX_Pac^.pnr := Chr(32 + PakkeNr);
    Next_Data_OK := FALSE;
  END
  ELSE
    MakeDataPac(TX_Pac^);
END;                         { MakeData }

PROCEDURE Ack(PakkeNr : WORD);
BEGIN
  SendPacket(PakkeNr,'Y','');
END;

PROCEDURE Nack(PakkeNr : WORD);
BEGIN
  SendPacket(PakkeNr,'N','');
END;

VAR state : KermitState;
    NackedNr : WORD;
    RX_Start : BOOLEAN;

PROCEDURE InitLesPakke;
BEGIN
  StartTimerSek(t2,YourTimeOut);
  RX_Start := TRUE;
END;

PROCEDURE LesPakke(VAR RX: PakkeType; VAR ok : BOOLEAN);
LABEL Ferdig, Init;
VAR bytes, n : WORD;
    buf : ARRAY [-3..100] OF CHAR ABSOLUTE RX;
BEGIN
  ok := FALSE;
  WITH RX DO BEGIN
    IF Retry <> r_ok THEN BEGIN
      IF r_code = r_timeout THEN
        MakePakke(RX,nut,'T','T')
      ELSE IF r_code = r_keyboard THEN
        MakePakke(RX,nut,'T','K')
      ELSE
        MakePakke(RX,nut,'E','F10');
      ok := TRUE;
      GOTO Init;
    END;
    IF RX_Start THEN BEGIN
      n := 100;
      REPEAT
        Dec(n);
        IF n = 0 THEN Exit;
        RS_ReadBlock(plen,96,bytes,CurComPort);
        IF bytes = 0 THEN Exit;
        Inc(ReceiveBytes,bytes);
      UNTIL plen = MySOH;
      RX_Start := FALSE;
      TotLen := 0;
      plen := '~';
    END;
    REPEAT
      RS_ReadBlock(buf[TotLen],96-TotLen,bytes,CurComPort);
      IF bytes = 0 THEN BEGIN
        IF TotLen > Ord(plen) - 32 THEN GOTO Ferdig;
        Exit;
      END;
      Inc(ReceiveBytes,bytes);
      IF NOT BinaryData AND (buf[TotLen] < ' ') THEN BEGIN
        IF buf[TotLen] = MyCR THEN GOTO Ferdig;
        IF buf[TotLen] = MySOH THEN BEGIN
          TotLen := 0;
          plen := '~';
        END;
        Exit;
      END;
      Inc(TotLen,bytes);
    UNTIL TotLen > 100;

  Ferdig:
    ok := TestPakke(RX) AND (TotLen < 96) AND NOT RX.long;
{$IFDEF DEBUG}
    IF LogFileMode = LogAll THEN BEGIN
      LogChar('<');
      FOR n := 0 TO Pred(TotLen) DO
        LogChar(buf[n]);
      LogChar('>');
    END;
{$ENDIF}
  Init:
    InitLesPakke;
  END;
END;                                   {LesPakke}

PROCEDURE TrySend;
BEGIN
  IF RS_Room(CurComPort) < 4000 THEN Exit; { >1 packet already in pipeline}
  IF NackedNr = 0 THEN BEGIN
    IF (ninn-nut) AND 63 < WinSize THEN BEGIN
      IF EndOfFile THEN BEGIN
{        IF nut = ninn THEN
        Debug('File completed'); }
        Exit;            {No more Data packets}
      END;
      PakkeNr := ninn;
      WITH pw[ninn] DO BEGIN
        MakeDataPac(dptr^);
        IF dptr^.TotLen > 0 THEN BEGIN
          SendPakkeT(dptr^);
          acknack := 0; {acked := FALSE; nacked := FALSE;}
          retry := 0;
          ninn := Succ(ninn) AND 63;
        END;
      END;
      Exit;
    END;
                                       {Window is full, see if any acked}
    IF pw[nut].retry > 0 THEN Exit;
    n := nut;
    REPEAT
      n := Succ(n) AND 63;
      IF n = ninn THEN Exit;
    UNTIL pw[n].acknack <> 0;
    SendPakkeT(pw[nut].dptr^);
    pw[nut].retry := 1;
    Exit;
  END
  ELSE BEGIN  {NackedNr > 0}
    n := nut;
    Dec(NackedNr);
    WHILE NOT pw[n].nacked DO BEGIN
      n := Succ(n) AND 63;
      IF n = ninn THEN BEGIN
        Warning('No NACK');
        Exit;
      END;
    END;
    SendPakkeT(pw[n].dptr^);
    pw[n].nacked := FALSE;
  END;
END;                                   {TrySend}

PROCEDURE DoPakke;
VAR msg : String;
BEGIN
  WITH RX_Pac^ DO BEGIN
{    IF EndOfFile THEN Debug('EOF - '+Tstr((ninn-nut) AND 63,1));  }
    WriteTotalNr;
    nr := -32 +Ord(pnr);                  {Position in circular buffer}
    n := (nr - nut) AND 63;            {Offset from first packet}

    Extract(msg);

    IF ptype = 'T' THEN BEGIN
      RS_Enable(CurComPort);
      WriteFeilNr;
      WITH pw[nut] DO BEGIN
        IF NOT nacked THEN BEGIN
          Inc(NackedNr);
          nacked := TRUE;
        END;
      END;
      Inc(RetryNr);
      IF RetryNr > 10 THEN BEGIN
        SendAbort('Too many retries!');
        state := Abort;
      END;
      Exit;
    END;

    RetryNr := 0;

    IF ptype = 'Y' THEN BEGIN
      IF msg = 'X' THEN BEGIN
        StopFile := TRUE;
        state := SendEOF;
      END;
      IF n >= (ninn-nut) AND 63 THEN BEGIN
{        Debug('ACK outside');  }
        Exit;    {ACK outside of window}
      END;
      WITH pw[nr] DO BEGIN
        acked := TRUE;
        IF nacked THEN BEGIN
          Dec(NackedNr);
          nacked := FALSE;
        END;
      END;
      WHILE pw[nut].acked DO BEGIN
        nut := Succ(nut) AND 63;
        IF ninn = nut THEN BEGIN
          IF EndOfFile THEN BEGIN
            state := SendEOF;
{            Debug('Exit TrySend'); }
          END;
          Exit;
        END;
      END;
      Exit;
    END;
    IF ptype = 'N' THEN BEGIN
      RS_Enable(CurComPort);
      IF n >= (ninn-nut) AND 63 THEN BEGIN {NACK outside window}
{        Debug('NACK outside');  }
        IF nut = ninn THEN BEGIN
{          Debug('Window empty'); }
          Exit;
        END;
        nr := nut
      END;
      WriteFeilNr;
      WITH pw[nr] DO BEGIN
        Inc(retry);
        IF retry > 10 THEN BEGIN
          SendAbort('Too many retries!');
          state := Abort;
          Exit;
        END;
        NackedNr := Succ(NackedNr) - Ord(nacked);
        nacked := TRUE;
      END;
      Exit;
    END;
    IF ptype = 'E' THEN BEGIN
      Extract(ErrorString);
      IF ErrorString <> 'F10' THEN
        WriteError;
      state := Abort;
      Exit;
    END;
    SendAbort('Unexpected packet type: '+ptype);
    state := Abort;
  END;
END;

PROCEDURE SendWindow;
VAR done : BOOLEAN;
    i : WORD;
BEGIN
  NackedNr := 0;
  InitLesPakke;
  InitWindow;
  REPEAT
    TrySend;
    FOR i := 1 TO 4 DO BEGIN
      LesPakke(RX_Pac^,done);          {Bad packet will be ignored}
      IF done THEN DoPakke;
    END;
    DumpPointers;
    IF StopFile AND (state<>Abort) THEN state := SendEOF;
  UNTIL state IN [SendEOF,Abort];
{
  IF state = SendEOF THEN
    Debug('Exit SendEOF')
  ELSE
    Debug('Exit Abort');
}
  PakkeNr := ninn;
END;

PROCEDURE SendManyFiles(FilePattern : String);
VAR ok, server : BOOLEAN;
    po : INTEGER;
    fn : String;
BEGIN
  server := FilePattern <> '';
  IF NOT server THEN BEGIN
    ReadFileName('File(s) to send: ',FilePattern);
    IF FilePattern = '' THEN Exit;
  END;

  IF Pos('.',FilePattern) = 0 THEN
    FilePattern := FilePattern + '.';
  FindFirst(FilePattern,0,DTA);
  ok := DosError = 0;
  IF NOT ok THEN BEGIN
    Error('No files found!');
    Exit;
  END;

  FileName := DTA.Name;

    po := Ord(FilePattern[0]);
    WHILE po > 0 DO BEGIN
      IF FilePattern[po] IN ['\',':'] THEN BEGIN
        Delete(FilePattern,po+1,30);
        po := 0;
      END;
      Dec(po);
    END;
    IF po = 0 THEN FilePattern[0] := #0;
    state := SendInit;
    ShowTimeOut := TRUE;
    PakkeNr := 0;
    FeilNr := 0;
    TotalNr := 0;
    LastNr := 63;
    MakeInfoScreen('  Sending:');
    StatusString := 'Init';
    WriteStatus;
    InitStat;
    RS_ClrBuffer(CurComPort);
    REPEAT
      CASE state OF
        SendData : BEGIN
                     IF WindowData THEN SendWindow
                     ELSE BEGIN
                       MakeData;
                       IF StopFile OR (TX_Pac^.TotLen = 0) THEN
                         state := SendEOF
                       ELSE BEGIN
                         SendAndGet(state,SendData,TRUE);
                         IF state=Abort THEN BEGIN
                           Close(fil);
                         END
                         ELSE IF (RX_Pac^.TotLen > 4) AND
                                 (RX_Pac^.pdata[1] = 'X') THEN BEGIN
                           StopFile := TRUE;
                           state := SendEOF;
                         END;
                       END;
                     END;
                   END;
        SendInit : BEGIN
                     MakeInitPacket('S');
                     SendAndGet(state,SendName,FALSE);
                     IF state=SendName THEN BEGIN
                       TolkInitPacket;
                       MakeCodeTab;
                       CheckType := FileCheck;
                     END;
                   END;
        SendName : BEGIN
                     fn := FilePattern + FileName + #0;
                     OriginalName := FileName;
                     Assign(fil,fn);
                     Reset(fil,1);
                     Next_Data_OK := FALSE;
                     IF IOresult = 0 THEN BEGIN
                       WriteFileName;
                       FileMax := FileSize(fil);
                       WriteFileSize;
                       Inc(FileNr);
                       MakePakke(TX_Pac^, PakkeNr,'F',FileName);
                       SendAndGet(state,SendData,FALSE);
                       IF state=SendData THEN BEGIN
                         BufCount := 0;
                         BufferPtr(BufPtr) := Buffer;
                         EndOfFile := FALSE;
                         ZeroBytes;
                         StatusString := 'In Progress';
                         WriteStatus;
                         StopFile := FALSE;
                         IF AttrPakke THEN state := SendAttr;
                       END;
                     END
                     ELSE BEGIN
                       Error('File not found: '+fn);
                       state := Abort;
                     END;
                   END;
        SendAttr : BEGIN
                     XmitAttr(state);
                     IF state = Abort THEN
                       Close(fil)
                   END;
        SendEOF  : BEGIN
                     XmitEOF (state);
                     IF state <> Abort THEN BEGIN
                       FindNext(DTA);
                       ok := DosError = 0;
                       IF ok THEN BEGIN
                         state := SendName;
                         FileName := DTA.Name;
                       END
                       ELSE
                         state := SendEnd;
                     END;
                   END;
        SendEnd  : BEGIN
                     XmitEnd(state);
                     StatusString := 'Completed!';
                     WriteStatus;
                   END;
        Abort    : BEGIN
                     StatusString := 'Aborted';
                     WriteStatus;
                     SendAbort('Too many retries!');
                     Close(fil);
                     ErrorLevel := 3;
                   END;
      END;
    UNTIL state IN [Complete,Abort];
  Bell;
  ShowStat;
END;  { SendManyFiles }

TYPE PakkeChar = 'A'..'Z';
     PakkeSet = SET OF PakkeChar;
     ReceiveType = (RecF, GetF, ServF, TextF);

VAR Ferdig, CheckSkip, ValidDate : BOOLEAN;
    Expect : PakkeSet;

PROCEDURE TestDate;
VAR old : FILE;
    newTime, oldTime : LongInt;
BEGIN
  IF OriginalName <> FileName THEN BEGIN
    Assign(old,OriginalName); Reset(old,1);
    GetFTime(old,oldTime);
    Close(old);

    PackTime(FTime,newTime);
    IF ((newTime > oldTime) AND (NewDupHandle = SkipFile)) OR
       ((newTime <= oldTime) AND (OldDupHandle = SkipFile)) THEN
      StopFile := TRUE;
  END;
  CheckSkip := TRUE;
  IF IOresult <> 0 THEN WriteStr('Test Error'^G);
END;

PROCEDURE GetFileAttr;
VAR l, st : String;
    p, feil, len : INTEGER;
BEGIN
  Extract(st);
    WHILE st[0] >= #3 DO BEGIN
      len := Ord(st[2]) - 32;
      l := Copy(st,3,len);
      CASE st[1] OF
        '!' : BEGIN GotoXY(30,8); WriteStr('File size: '+Pad(l+'k',10)); END;
        '1' : BEGIN GotoXY(30,8); WriteStr('File size: '+Pad(l,10)); END;
        '#' : BEGIN
                p := Pos(' ',l);
                Val(Copy(l,p-6,2),FTime.year,feil);
                Inc(FTime.year,1900);
                IF feil = 0 THEN Val(Copy(l,p-4,2),FTime.month,feil);
                IF feil = 0 THEN Val(Copy(l,p-2,2),FTime.day,feil);
                IF feil = 0 THEN Val(Copy(l,p+1,2),FTime.hour,feil);
                IF feil = 0 THEN Val(Copy(l,p+4,2),FTime.min,feil);
                IF (feil = 0) AND (Ord(l[0]) >= p + 8) THEN
                  Val(Copy(l,p+7,2),FTime.sec,feil);
                IF feil = 0 THEN BEGIN
                  ValidDate := TRUE;
                  TestDate;
                END;
              END;
      END;
      Delete(st,1,len+2);
    END;
END;

PROCEDURE SetFileDate;
VAR t : LongInt;
BEGIN
  IF NOT ValidDate THEN Exit;
  PackTime(FTime,t);
  SetFTime(fil,t);
END;

VAR CtrlTab : ARRAY [CHAR] OF CHAR;

PROCEDURE MakeCtrlTab;
VAR ch : CHAR;
BEGIN
  FOR ch := #0 TO #255 DO CtrlTab[ch] := ch;
  FOR ch := #$3F TO #$5F DO CtrlTab[ch] := Chr(Ord(ch) XOR 64);
  FOR ch := #$BF TO #$DF DO CtrlTab[ch] := Chr(Ord(ch) XOR 64);
END;

PROCEDURE DecodeData(VAR p : PakkeType);
VAR n, mask : BYTE;
    ch : CHAR;
    dptr : ^CHAR;
    dlen, max, databytes : WORD;
BEGIN
  IF DiskError THEN Exit;
  max := 1;
  IF p.long THEN max := 4;
  dptr := Addr(p.pdata[max]);
  max := Ofs(p.pdata[p.TotLen - 2 - CheckType]);
  databytes := 0;
  IF BinaryData THEN BEGIN
    dlen := max - Word(dptr);
    IF BufCount < dlen THEN BEGIN
      Move(dptr^,BufPtr^,BufCount);
      BlockWrite(fil,buffer^,BufSize);
      IF IOresult <> 0 THEN BEGIN
        DiskError := TRUE;
        Exit;
      END;
      Inc(Word(dptr),BufCount);
      AddBytes(BufCount);
      Dec(dlen,BufCount);
      BufferPtr(BufPtr) := Buffer;
      BufCount := BufSize;
    END;
    Move(dptr^,BufPtr^,dlen);
    Inc(Word(BufPtr),dlen);
    Dec(BufCount,dlen);
    AddBytes(dlen);

    Exit;
  END;

  REPEAT
    ch := dptr^; Inc(WORD(dptr));
    n := 1;
    IF ch = RepQ THEN BEGIN
      n := BYTE(dptr^) - 32; Inc(WORD(dptr));
      ch := dptr^; Inc(WORD(dptr));
    END;
    mask := 0;
    IF ch = Bit8Q THEN BEGIN
      mask := $80;
      ch := dptr^; Inc(WORD(dptr));
    END;
    IF ch = YourQCtrlChar THEN BEGIN
      ch := CtrlTab[dptr^]; Inc(WORD(dptr));
    END;

    ch := CHAR(BYTE(ch) OR mask);

    IF TextFile THEN ch := InnConvert[ch];
    Inc(databytes,n);

    REPEAT
      BufPtr^ := ch;
      Inc(Word(BufPtr));
      Dec(BufCount);
      IF BufCount = 0 THEN BEGIN
        StopLink;
        BlockWrite(fil,buffer^,BufSize);
        StartLink;
        BufferPtr(BufPtr) := Buffer;
        BufCount := BufSize;
        IF IOresult <> 0 THEN BEGIN
          DiskError := TRUE;
          Exit;
        END;
      END;
      Dec(n);
    UNTIL n = 0;
  UNTIL WORD(dptr) >= max;
  AddBytes(databytes);
END;                                   {DecodeData}

PROCEDURE EOF_Packet;
VAR EraseFile : BOOLEAN;
    old, bak : FILE;
    Bak_file : String[64];
    punkt : INTEGER;
    oldTime, newTime : LongInt;
BEGIN
  Extract(st);
  IF BufCount < BufSize THEN BlockWrite(fil,Buffer^,BufSize-BufCount);
  SetFileDate;
  Inc(TotalBytes,FilePos(fil));
  Close(fil);
  IF (st = 'D') OR StopFile THEN BEGIN
    Erase(fil);
    Warning(Filename+' skipped!');
  END
  ELSE BEGIN
    IF OriginalName <> FileName THEN BEGIN
      Assign(old,OriginalName); Reset(old,1);
      IF ValidDate THEN BEGIN
        GetFTime(old,oldTime);
        PackTime(FTime,newTime);
        EraseFile := ((newTime>oldTime) AND (NewDupHandle=OverWriteFile)) OR
                    ((newTime<=oldTime) AND (OldDupHandle=OverWriteFile));
      END
      ELSE BEGIN
        EraseFile := DupHandle = OverWriteFile;
      END;
      Close(old);
      IF EraseFile THEN BEGIN
        punkt := Pos('.',OriginalName);
        IF punkt = 0 THEN punkt := Length(OriginalName)+1;
        BAK_file := Copy(OriginalName,1,punkt-1) + '.BAK';
        IF (OriginalName <> BAK_File) THEN BEGIN
          IF Exist(BAK_File) THEN BEGIN
            Assign(bak,BAK_File);
            Erase(bak);
          END;
          Rename(old,BAK_File);
          Rename(fil,OriginalName);
          Warning(FileName+' renamed to '+OriginalName);
        END;
      END;
    END;
  END;
  IF IOresult=0 THEN
    Ack(PakkeNr)
  ELSE BEGIN
    SendAbort('File close error!');
    Ferdig := TRUE;
  END;
  Expect := ['B','F'];
  StatusString := 'File Closed';
  WriteStatus;
END;

PROCEDURE TestPacketNr(VAR ok : BOOLEAN);
VAR i, j : WORD;
BEGIN
  ok := FALSE;
  n := (nr - nut) AND 63;
  IF n < (ninn-nut) AND 63 THEN BEGIN
    ok := n < WinSize;                 {Retransmitted packet}
    Exit;
  END;
  i := (nr - ninn) AND 63;             {Packets past last}
  IF i >= WinSize THEN Exit;           {Outside of max send window}
  FOR j := 0 TO i DO BEGIN
    IF (ninn-nut) AND 63 = WinSize THEN BEGIN
      IF NOT pw[nut].acked THEN BEGIN
        SendAbort('Window overflow!');
        ferdig := TRUE;
        Exit;
      END;
      DecodeData(pw[nut].dptr^);
      nut := Succ(nut) AND 63;
    END;
    WITH pw[ninn] DO BEGIN
      retry := 0;
      acked := FALSE;
      IF j < i THEN BEGIN
        Nack(ninn);
        retry := 1;
      END;
    END;
    ninn := Succ(ninn) AND 63;
  END;
  ok := TRUE;
END;                                   { TestPacketNr }

PROCEDURE WindowReceive;
VAR ok : BOOLEAN;
BEGIN                                  { RX_Pac has the first data packet }
  InitWindow;
  REPEAT
   DumpPointers;
   WITH RX_Pac^ DO BEGIN
    nr := -32 +Ord(pnr);
    CASE ptype OF
      'T' : BEGIN
        Inc(RetryNr);
        WriteFeilNr;
        IF RetryNr > 10 THEN BEGIN
          SendAbort('Too many timeouts!');
          Ferdig := TRUE;
          Exit;
        END;
        n := nut;
        WHILE pw[n].acked AND (n <> ninn) DO n := Succ(n) AND 63;
        IF (n <> ninn) OR (pdata[1] <> 'P') THEN
          Nack(n);                         { Most wanted packet nr! }
        RS_Enable(CurComPort);
      END;
      'E' : BEGIN
        Extract(ErrorString);
        IF ErrorString <> 'F10' THEN WriteError;
        IF ErrorLevel < 2 THEN ErrorLevel := 2;
        Ferdig := TRUE;
        Exit;
      END
      ELSE BEGIN
        RetryNr := 0;
        IF ptype = 'Z' THEN BEGIN
          Extract(st);
          IF st <> 'D' THEN BEGIN
            WHILE nut <> ninn DO BEGIN
              IF NOT pw[nut].acked THEN BEGIN
                SendAbort('No ACK at EOF:'+pnr);
                Ferdig := TRUE;
                Exit;
              END;
              DecodeData(pw[nut].dptr^);
              nut := Succ(nut) AND 63;
              DumpPointers;
            END;
          END;
          PakkeNr := nr;
          EOF_Packet;
          Exit;
        END;
        IF StopFile THEN
          SendPacket(nr,'Y','X')
        ELSE IF DiskError THEN BEGIN
          SendAbort('File write error!');
          ferdig := TRUE;
          Exit;
        END
        ELSE BEGIN
          TestPacketNr(ok);              {Sjekk om nr i vindu, sett n}
          IF ferdig THEN Exit;
          IF ok THEN WITH pw[nr] DO BEGIN
            IF ptype = 'D' THEN BEGIN
              IF NOT acked THEN BEGIN
                Move(RX_Pac^,dptr^,100);{Room for overhead}
                acked := TRUE;
              END
              ELSE BEGIN
                Inc(retry);
                IF retry > 10 THEN BEGIN
                  SendAbort('Too many retries!');
                  ferdig := TRUE;
                  Exit;
                END;
              END;
              Ack(nr);
            END
            ELSE BEGIN
              SendAbort('Unexpected packet type: '+ptype);
              Ferdig := TRUE;
              Exit;
            END;
          END
          ELSE BEGIN
            WriteFeilNr;
          END
        END;
      END;  {ELSE BEGIN}
    END;    {CASE ptype OF}
    GetPakke;
    WriteTotalNr;
   END;          {WITH RX_Pac^ DO}
  UNTIL FALSE;
END;                                   { WindowReceive }

PROCEDURE ReceiveFiles(GetFile : ReceiveType; GetName : String);
VAR LastPk : PakkeCh;
    state : KermitState;
    l, n : INTEGER;
    ch : CHAR;
    MainName, Ext, Path, st : String;
    ok, done : BOOLEAN;
BEGIN
  IF (GetFile=GetF) AND (GetName = '') THEN BEGIN
    ReadFileName('File(s) to Get: ',GetName);
    IF GetName[0]=#0 THEN Exit;
  END;
  RS_ClrBuffer(CurComPort);
  Expect := ['S'];
  LastPk := '@';
  PakkeNr := 0;
  TotalNr := 0;
  FeilNr  := 0;
  LastNr := 63;
  RetryNr := 0;
  Ferdig := FALSE;
  ShowTimeOut := TRUE;
  MakeInfoScreen('Receiving:');
  FileName[0] := #0;
  ErrorString[0] := #0;
  StatusString := 'Init';
  WriteStatus;
  RS_ClrBuffer(CurComPort);
  DiskError := FALSE;
  IF GetFile=GetF THEN BEGIN
    MakeInitPacket('I');
    SendAndGet(state,Complete,FALSE);
    IF state=Complete THEN
      TolkInitPacket;
    SendPacket(0,'R',GetName);
  END;
  PakkeNr := 0;

  IF GetFile<>ServF THEN
    GetPakke;

  InitStat;
  REPEAT
    WITH RX_Pac^ DO BEGIN
      IF ptype = 'T' THEN BEGIN
        Inc(RetryNr);
        IF RetryNr <= RetryLimit THEN BEGIN
          WriteFeilNr;
          Nack(PakkeNr);
        END
        ELSE BEGIN
          SendAbort('Too many retries!');
          Ferdig := TRUE;
          ErrorLevel := 1;
        END;
      END
      ELSE BEGIN
        RetryNr := 0;
        IF (pnr = Chr(32 + PakkeNr)) AND (ptype IN Expect) THEN BEGIN
          CASE ptype OF
            'D' :
            BEGIN
              IF NOT CheckSkip THEN BEGIN
                IF OriginalName <> FileName THEN
                  StopFile := DupHandle = SkipFile;
                CheckSkip := TRUE;
              END;
              IF WindowData THEN
                WindowReceive
              ELSE IF StopFile THEN
                SendPacket(PakkeNr,'Y','X')
              ELSE IF DiskError THEN
                SendAbort('File write error!')
              ELSE BEGIN
                IF NOT DiskStopInt THEN Ack(PakkeNr);
                Expect := ['D','Z'];
                DecodeData(RX_Pac^);
                IF DiskStopInt THEN Ack(PakkeNr);
              END;
            END;
            'S' : BEGIN
                    TolkInitPacket;
                    RepQ := #0;
                    IF Qrep THEN RepQ := QrepChar;
                    Bit8Q := #0;
                    IF Q8bit THEN Bit8Q := Q8bitChar;
                    MakeInitPacket('Y');
                    SendPakke;
                    CheckType := FileCheck;
                    IF GetFile = TextF THEN
                      Expect := ['X']
                    ELSE
                      Expect := ['F'];
                    StatusString := 'GetFileName';
                    WriteStatus;
                    MakeCtrlTab;
                  END;
            'X' :
            BEGIN
              FileName := 'CON'; OriginalName := FileName;
              Assign(fil,'KERMIT.$$$');
              ReWrite(fil,1);
              IF IOresult<>0 THEN BEGIN
                SendAbort('Cannot Create File!');
                Ferdig := TRUE;
              END
              ELSE BEGIN
                CheckSkip := FALSE;
                ValidDate := FALSE;
                BufferPtr(BufPtr) := Buffer;
                BufCount := BufSize;
                Expect := ['A','D','Z'];
                StatusString := 'In progress';
                WriteStatus;
                WriteFileName;
                ZeroBytes;
                StopFile := FALSE;
                Ack(PakkeNr);
                LongReply := TRUE;
              END;
            END;
            'F' :
            BEGIN
              Inc(FileNr);
              Extract(FileName);
              FOR l := 1 TO Ord(FileName[0]) DO
                IF NOT (FileName[l] IN FileNameSet) THEN
                  FileName[l] := 'X';
              Ext := '.';
              MainName[0] := #0;
              Path[0] := #0;
              IF Pos(':',FileName) = 2 THEN BEGIN
                Path := Copy(FileName,1,2);
                IF NOT (Path[1] IN ['A'..'Z']) THEN Path[0] := #0;
                Delete(FileName,1,2);
              END;
              l := Ord(FileName[0]);
              WHILE l > 0 DO BEGIN
                IF FileName[l] = '.' THEN BEGIN
                  IF Ext = '.' THEN BEGIN
                    Ext := Copy(FileName,l,4);
                    FileName := Copy(FileName,1,Pred(l));
                  END
                  ELSE
                    FileName[l] := 'X';
                END
                ELSE IF FileName[l] = '\' THEN BEGIN
                  Path := Path + Copy(FileName,1,l);
                  Delete(FileName,1,l);
                  l := 0;
                END
                ELSE IF FileName[l] = ':' THEN
                  FileName[l] := 'X';
                Dec(l);
              END;
              IF FileName[0] > #8 THEN FileName[0] := #8;
(*
              IF Path = '' THEN BEGIN
                Path := DownLoadPath;
                IF Path[Length(Path)] <> '\' THEN
                  Path := Path + '\';
              END;
*)
              OriginalName := Path+FileName+Ext;

              MainName := Copy(FileName+'________',1,8);
              l := 1;
              FileName := OriginalName;

              WHILE Exist(FileName) AND (l<100) DO BEGIN
                MainName[8] := Chr(l MOD 10 + 48);
                IF l>9 THEN MainName[7] := Chr(l DIV 10 + 48);
                FileName := MainName+Ext;
                Inc(l);
              END;
              IF Exist(FileName) THEN BEGIN
                SendAbort('Existing File!');
                Ferdig := TRUE;
              END
              ELSE BEGIN
                Assign(fil,FileName);
                ReWrite(fil,1);
                IF IOresult<>0 THEN BEGIN
                  SendAbort('Cannot Create File!');
                  Ferdig := TRUE;
                END
                ELSE BEGIN
                  CheckSkip := FALSE;
                  ValidDate := FALSE;
                  BufferPtr(BufPtr) := Buffer;
                  BufCount := BufSize;
                  Expect := ['A','D','Z'];
                  StatusString := 'In progress';
                  WriteStatus;
                  WriteFileName;
                  ZeroBytes;
                  StopFile := FALSE;
                  Ack(PakkeNr);
                END;
              END;
              LongReply := FALSE;
            END;
            'A' : BEGIN
                    GetFileAttr;
                    IF StopFile THEN
                      SendPacket(PakkeNr,'Y','N')
                    ELSE
                      Ack(PakkeNr);
                  END;
            'Z' : EOF_Packet;
            'B' : BEGIN
                    Ack(PakkeNr);
                    Ferdig := TRUE;
                    StatusString := 'Completed';
                    WriteStatus;
                  END;
          END;  { CASE }
          LastPk := ptype;
          LastNr := PakkeNr;
          PakkeNr := Succ(PakkeNr) AND 63;
          RetryNr := 0;
          WriteTotalNr;
        END
        ELSE IF (pnr = Chr(32 + LastNr)) AND (ptype = LastPk) THEN BEGIN
          Inc(RetryNr);
          WriteFeilNr;
          IF RetryNr > RetryLimit THEN BEGIN
            SendAbort('Too many retries!');
            Ferdig := TRUE;
          END
          ELSE BEGIN
            IF ptype = 'S' THEN BEGIN
              MakeInitPacket('Y');
              SendPakke;
            END
            ELSE
              Ack(LastNr);
          END;
        END
        ELSE IF ptype = 'E' THEN BEGIN
          Extract(ErrorString);
          IF ErrorString <> 'F10' THEN WriteError;
          IF ErrorLevel < 2 THEN ErrorLevel := 2;
          Ferdig := TRUE;
        END
        ELSE IF (ptype = 'D') AND WindowData THEN
          WindowReceive
        ELSE IF (ptype <> 'Y') AND (ptype <> 'N') AND
                (pnr <> Chr(32 + LastNr)) THEN BEGIN
          SendAbort('Wrong packet type: '+ptype);
          Ferdig := TRUE;
        END;
      END;
    END;
    IF NOT ferdig THEN
      GetPakke;
  UNTIL Ferdig;
  IF 'D' IN Expect THEN BEGIN
    Close(fil);
    IF IOresult = 0 THEN
      Erase(fil);
  END;
  Bell;
  ShowStat;
  IF LongReply THEN {ShowReply};
END;                         { ReceiveFiles }

PROCEDURE HostCommand;
BEGIN
  ClrLast;
  WriteStr('Remote Directory: ');
  SendPacket(0,'G','D');
  GetPakke;
  IF RX_Pac^.ptype = 'Y' THEN BEGIN
    Extract(st);
    IF st = '' THEN BEGIN
      ReceiveFiles(TextF,'');
    END
    ELSE BEGIN
      GotoXY(1,25);
      WriteLn(st);
    END;
    GetF10;
  END;
END;                                   {HostCommand}

PROCEDURE FinishServer;
BEGIN
  ClrLast;
  WriteStr('Logging out remote server: ');
  SendPacket(0,'G','F');
  GetPakke;
  IF RX_Pac^.ptype = 'Y' THEN BEGIN
    WriteStr('Done!');
    Delay(1000);
  END;
END;                         { FinishServer }

VAR
  StartPath : String[80];

PROCEDURE Server;
VAR FilP, FilN, st : String;
    ok, ResetTimer : BOOLEAN;
BEGIN
  ResetTimer := TRUE;
  ClrScr;
  REPEAT
    IF (ServerTime > 0) AND ResetTimer THEN BEGIN
      MaxServer.count := ServerTime * 1092;
      MaxServer.UserInt := FALSE;
      StartTimer(MaxServer);
    END;
    CheckType := 1;                          { First packet is always type 1 }
    ClrLast;
    WriteStr('Kermit  SERVER');
    GotoXY(72,MaxY); WriteStr('F10=Exit');
    PakkeNr := 0;
    GetPakke;
    ResetTimer := TRUE;
    ShowTimeOut := FALSE;
    IF RX_Pac^.pnr = ' ' THEN BEGIN
      CASE RX_Pac^.ptype OF
        'S' : ReceiveFiles(ServF,'');
        'I' : BEGIN
                TolkInitPacket;
                MakeInitPacket('Y');
                SendPakke;
              END;
        'R' : BEGIN
                Extract(FilP);
                IF FilP[0] = #0 THEN
                  ok := FALSE
                ELSE BEGIN
                  IF Pos('.',FilP) = 0 THEN FilP := FilP + '.';
                  FindFirst(FilP,0,DTA);
                  ok := DosError = 0;
                END;
                IF ok THEN
                  SendManyFiles(FilP)
                ELSE
                  SendAbort('No Files Found!');
              END;
        'T' : BEGIN
                IF ServerTimeOut THEN Nack(PakkeNr);
                ResetTimer := FALSE;
              END;
        'E' : BEGIN
                Extract(ErrorString);
                IF ErrorString = 'F10' THEN BEGIN
                  IF ErrorLevel = 0 THEN ErrorLevel := 1;
                  Exit;
                END;
                WriteError;
              END;
        'G' : BEGIN
                Extract(st);
                IF st[1] IN ['F','L'] THEN BEGIN
                  Ack(0);
                  Exit;
                END
                ELSE
                  SendAbort('Unknown Generic Command!');
              END;
        'C' : BEGIN
                Extract(st);
                IF st = '' THEN st := StartPath;
                ChDir(st);
                GetDir(0,DownLoadPath);
                IF IOresult = 0 THEN ;
                SendPacket(PakkeNr,'Y','New dir: '+DownLoadPath);
              END;
        ELSE SendAbort('Unknown Server Command!');
      END;
    END
    ELSE
      Nack(PakkeNr);
  UNTIL (ServerTime > 0) AND NOT RunningTimer(MaxServer);
END;                                   {Server}

{$I Terminal}

PROCEDURE Kermit;
VAR
  key : KeyType;
  heap : Pointer;
  st : String;
  i : INTEGER;
BEGIN                        { Kermit }
  Mark(heap);

  New(RX_Pac); New(TX_Pac); New(Next_Pac);

  IF MemAvail < KermitBufSize + 2048 THEN
    KermitBufSize := (MemAvail - 2048) AND $F800;

  GetMem(buffer,KermitBufSize+1);
  BufSize := KermitBufSize;

  AttrPakke := TRUE;

  YourMaxLength := 80;
  PakkeNr := 0;
  ServerTime := 0;
  PacketDelay := 0;
  r_code := r_ok;

  IF ArgC >= 1 THEN BEGIN
    ShowTimeOut := TRUE;
    CheckType := 1;

    Init_Params;

    st := ArgV[1];

    IF Pos(st,'SERVER') = 1 THEN Server
    ELSE IF (Pos(st,'SEND') = 1) AND (ArgC >= 2) THEN SendManyFiles(ArgV[2])
    ELSE IF Pos(st,'RECEIVE') = 1 THEN ReceiveFiles(RecF,'')
    ELSE IF (Pos(st,'GET') = 1) AND (ArgC >= 2) THEN ReceiveFiles(GetF,ArgV[2])
    ELSE BEGIN
      GotoXY(1,25);
      WriteLn('Usage: Kermit [SERVER] | [SEND <file>] | [RECEIVE] | [GET <file>');
      Exit;
    END;
  END
  ELSE BEGIN
    REPEAT
      ShowTimeOut := TRUE;
      CheckType := 1;

      Meny(key);

      CASE key OF
      1 : BEGIN
            SendManyFiles('');
            GetF10;
          END;
      2 : BEGIN
            ReceiveFiles(RecF,'');
            GetF10;
          END;
      3 : BEGIN
            ReceiveFiles(GetF,'');
            GetF10;
          END;
      4 : Server;
      5 : SaveParam;
      6 : HostCommand;
      7 : BEGIN
            GotoXY(1,25); WriteLn; CursorOn; Exec(FindEnv('COMSPEC='),'');
            IF DosError <> 0 THEN BEGIN
              WriteLn('EXEC error # ',DosError);
              Delay(2000);
            END;
          END;
      8 : BEGIN
            GotoXY(1,25);
            ClrEol;
            GotoXY(72,25); Write('F10-Exit');
            Window(1,18,80,24);
            ClrScr;
            CursorOn;
            Terminal;
            Window(1,1,80,25);
          END;
      9 : FinishServer;
      END;
    UNTIL key = 10;
  END;
  Release(heap);
END;                         { Kermit }

VAR
  ok : BOOLEAN;
  ch : CHAR;
  key : WORD;

CONST
  US_Tab : ARRAY [1..6] OF CHAR = '[\]{|}';
  NO_Tab : ARRAY [1..6] OF CHAR = '';

BEGIN                                  {Kermits}
{  CheckBreak := FALSE; }
  FileMode := 0;

  OrigText := TextAttr;
  OrigMenu := OrigText XOR 8;
  OrigField := FeltAttr;
  OrigEdit := EditAttr;

  GetDir(0,StartPath); DownLoadPath := StartPath;

  FOR ch := #0 TO #255 DO InnConvert[ch] := ch;
  UtConvert := InnConvert;
  FOR key := 1 TO 6 DO BEGIN
    InnConvert[US_Tab[key]] := NO_Tab[key];
    UtConvert[NO_Tab[key]] := US_Tab[key];
  END;

  RS_MakeBuffer($1000,0,0,0,0);        {Use same buffers for all ports!}

  MakeStr(4,5,64,LeftJ,'Current Dir: ',DownLoadPath,Addr(FileNameSet),ToUpper);

  MakeLong(10,7,6,LeftJ,'Baud: ',CurBaud,2,115200);
  MakeWord(10,8,1,LeftJ,'Bits: ',CurBits,7,8);
  MakeEnum(8,9,5,CenterJ,'Parity: ',CurParity,5,ParityStr);
  MakeWord(5,10,1,LeftJ,'Stop Bits: ',CurStop,1,2);
  MakeWord(6,11,1,LeftJ,'Com Port: ',CurComPort,1,4);

  MakeWord(32,7,4,LeftJ, 'Max Packet: ',LongMaxLength,20,9020);
  MakeWord(32,8,2,LeftJ, 'Max Window: ',WinSize,0,31);
  MakeWord(28,9,3,LeftJ, 'Packet Timeout: ',MyTimeOut,0,120);
  MakeWord(28,10,3,LeftJ,'Server Timeout: ',ServerTime,0,500);
  MakeByte(32,11,1,LeftJ,'Check Type: ',FileCheck,1,3);

  MakeBool(58,7,5,LeftJ, 'Long Packets: ',LongPakke);
  MakeBool(56,8,5,LeftJ, 'Sliding Window: ',WindowData);
  MakeEnum(61,9,4,LeftJ,  'File Type: ',TextFile,2,BinText);
  MakeEnum(62,10,3,LeftJ,  'IBM Mode: ',IBM_Mode,3,Std_IBM);
  MakeBool(60,11,5,LeftJ,'High Speed: ',BinaryData);

  MakeByte(2,13,2,LeftJ, 'Packet Start: ',BYTE(MySOH),1,31);
  MakeByte(4,14,2,LeftJ, 'Packet End: ',BYTE(MyCR),1,31);
  MakeChar(4,15,1,LeftJ, 'Ctl Prefix: ',MyQCtrlChar,NIL,0);
  MakeChar(3,16,1,LeftJ, '8bit Prefix: ',Q8bitChar,NIL,0);
  MakeChar(4,17,1,LeftJ, 'Rep Prefix: ',QrepChar,NIL,0);

  MakeEnum(34,15,10,CenterJ,' No Date: ',DupHandle,3,DupString);
  MakeEnum(34,16,10,CenterJ,'Old File: ',OldDupHandle,3,DupString);
  MakeEnum(34,17,10,CenterJ,'New File: ',NewDupHandle,3,DupString);

  MakeByte(60,13,3,LeftJ, 'Text Color: ',KermitAttr,0,255);
  MakeByte(60,14,3,LeftJ, 'Menu Color: ',MenuAttr,0,255);
  MakeByte(59,15,3,LeftJ,'Field Color: ',FieldAttr,0,255);
  MakeByte(60,16,3,LeftJ, 'Edit Color: ',EditAttr,0,255);

  MakeBool(58,17,5,LeftJ,'Direct Video: ',DirVideo);

  IF NOT GetParam THEN Halt(1);

  DirectVideo := DirVideo;
  ClrScr;        {Keep current screen colors!}

  CursorOff;
  Kermit;
  CursorOn;

  RS_Stop(CurComPort);
  ChDir(StartPath);
  GotoXY(1,25);
END.
<<< mydos.pas >>>
{$R-,S-}

Unit MyDos;

Interface

CONST
  IO_CTRL = $4000;
  IO_ISDEV  = $80;
  IO_EOF    = $40;
  IO_BINARY = $20;
  IO_ISCLK  =   8;
  IO_ISNUL  =   4;
  IO_ISCOT  =   2;
  IO_ISCIN  =   1;

  StdIn     =   0;
  StdOut    =   1;
  StdErr    =   2;
  StdLst    =   3;
  StdAux    =   4;

TYPE DiskInfo = RECORD
       Avail_Clu, Total_Clu, BytPrSec, SecPrClu : WORD;
     END;
const
  { Flags bit masks }
  FCarry     = $0001;
  FParity    = $0004;
  FAuxiliary = $0010;
  FZero      = $0040;
  FSign      = $0080;
  FOverflow  = $0800;

  { File attribute constants }
  ReadOnly  = $01;
  Hidden    = $02;
  SysFile   = $04;
  VolumeID  = $08;
  Directory = $10;
  Archive   = $20;
  AnyFile   = $3F;

type
  { Search record used by FindFirst and FindNext }
  SearchRec = record
                Fill: array[1..21] of Byte;
                Attr: Byte;
                Time: Longint;
                Size: Longint;
                Name: string[12];
              end;

  { Date and time record used by PackTime and UnpackTime }
  DateTime = record
               Year,Month,Day,Hour,Min,Sec: Word;
             end;
  String4 = String[4];

VAR DosError : WORD;

procedure GetFAttr(var F; var Attr: Word);
procedure SetFAttr(var F; Attr: Word);
procedure UnpackTime(P: Longint; var T: DateTime);
procedure PackTime(var T: DateTime; var P: Longint);
PROCEDURE ExecEnv(Path,CmdLine: String; environ : Pointer);

PROCEDURE GetTime(VAR hour, min, sec, s100 : WORD);
PROCEDURE GetDate(VAR year, month, day, dow : WORD);
PROCEDURE SetTime(hour, min, sec, s100 : WORD);
PROCEDURE SetDate(year, month, day : WORD);
PROCEDURE GetIntVec(nr : BYTE; VAR p : Pointer);
PROCEDURE SetIntVec(nr : BYTE; p : Pointer);
PROCEDURE FindFirst(path : String; attr : WORD; VAR dta : SearchRec);
PROCEDURE FindNext(VAR dta: SearchRec);
PROCEDURE GetFTime(VAR fil; VAR time : LongInt);
PROCEDURE SetFTime(VAR fil; time : LongInt);
FUNCTION  GetDevStat(handle : WORD) : WORD;
PROCEDURE GetDiskInfo(drive : WORD; VAR dinfo : DiskInfo);

FUNCTION DosVersion: WORD;
PROCEDURE Exec(Path,CmdLine: String);
FUNCTION FindEnv(find : String) : String;

PROCEDURE PutString(st : String);
FUNCTION Hex(w : Word): String4;
PROCEDURE ShrinkHeap;
PROCEDURE Move(VAR fra, til; bytes : WORD);

Implementation

PROCEDURE Move(VAR fra, til; bytes : WORD); {Erstatter SYSTEM:MOVE}
BEGIN
Inline(
  $1E                    {  push ds                ;}
  /$C5/$76/<FRA          {  lds si,<fra[bp]        ;}
  /$C4/$7E/<TIL          {  les di,<til[bp]        ;}
  /$FC                   {  cld                    ;}
  /$8B/$4E/<BYTES        {  mov cx,<bytes[bp]      ;}
  /$E3/$38               {  jcxz done              ;}
  /$39/$FE               {  cmp si,di              ;}
  /$77/$21               {    ja moveup            ;}
  /$FD                   {  std                    ;}
  /$89/$C8               {  mov ax,cx              ;}
  /$48                   {  dec ax                 ;}
  /$01/$C6               {  add si,ax              ;}
  /$01/$C7               {  add di,ax              ;}
  /$F7/$C6/$01/$00       {  test si,1              ;}
  /$75/$02               {    jnz dnw              ;}
  /$A4                   {  movsb                  ;}
  /$49                   {  dec cx                 ;}
                         {dnw:                     ;}
  /$4E                   {  dec si                 ;}
  /$4F                   {  dec di                 ;}
  /$D1/$E9               {  shr cx,1               ;}
  /$9F                   {  lahf                   ;}
  /$E3/$02               {    jcxz dnwd            ;}
  /$F2/$A5               {  rep movsw              ;}
  /$9E                   {dnwd: sahf               ;}
  /$73/$18               {    jnc done             ;}
  /$46                   {  inc si                 ;}
  /$47                   {  inc di                 ;}
  /$A4                   {  movsb                  ;}
  /$EB/$13               {    jmp short done       ;}
  /$F7/$C6/$01/$00       {moveup: test si,1        ;}
  /$74/$02               {    jz upw               ;}
  /$A4                   {  movsb                  ;}
  /$49                   {  dec cx                 ;}
  /$D1/$E9               {upw: shr cx,1            ;}
  /$9F                   {  lahf                   ;}
  /$E3/$02               {    jcxz upwd            ;}
  /$F2/$A5               {  rep movsw              ;}
  /$9E                   {upwd: sahf               ;}
  /$73/$01               {    jnc done             ;}
  /$A4                   {  movsb                  ;}
  /$1F                   {done: pop ds             ;}
);
END;                                   {Move}

FUNCTION DosVersion: WORD;
BEGIN
Inline(
  $B4/$30                {mov ah,$30}
  /$CD/$21               {int $21}
  /$86/$E0               {xchg al,ah}
  /$89/$46/$FE           {mov [bp-2],ax}
);
END;

PROCEDURE ShrinkHeap;
BEGIN
Inline(
  $8B/$1E/>HEAPPTR       {mov bx,[>HeapPtr]}
  /$81/$C3/$0F/$00       {add bx,15}
  /$B1/$04               {mov cl,4}
  /$D3/$EB               {shr bx,cl}
  /$03/$1E/>HEAPPTR+2    {add bx,[>HeapPtr+2]}
  /$89/$D8               {mov ax,bx}
  /$2D/$00/$10           {sub ax,$1000}
  /$A3/>FREEPTR+2        {mov [>FreePtr+2],ax}
  /$31/$C0               {xor ax,ax}
  /$A3/>FREEPTR          {mov [>FreePtr],ax}
  /$B4/$4A               {mov ah,$4A}
  /$8E/$06/>PREFIXSEG    {mov es,[>PrefixSeg]}
  /$2B/$1E/>PREFIXSEG    {sub bx,[>PrefixSeg]}
  /$CD/$21               {int $21}
);
END;

FUNCTION Hex(w : Word): String4;
CONST HexCh : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
VAR   h : String4;
BEGIN
  h[0] := #4;
  h[1] := HexCh[Hi(w) Shr 4];
  h[2] := HexCh[Hi(w) AND 15];
  h[3] := HexCh[Lo(w) Shr 4];
  h[4] := HexCh[Lo(w) AND 15];
  Hex := h;
END;

PROCEDURE SetTime(hour, min, sec, s100 : WORD);
BEGIN
Inline(
  $8A/$56/<S100          {mov dl,[bp+<s100]}
  /$8A/$76/<SEC          {mov dh,[bp+<sec]}
  /$8A/$4E/<MIN          {mov cl,[bp+<min]}
  /$8A/$6E/<HOUR         {mov ch,[bp+<hour]}
  /$B4/$2D               {mov ah,$2D}
  /$CD/$21               {int $21}
);
END;

PROCEDURE SetDate(year, month, day : WORD);
BEGIN
Inline(
  $8B/$4E/<YEAR          {mov cx,[bp+<year]}
  /$8A/$76/<MONTH        {mov dh,[bp+<month]}
  /$8A/$56/<DAY          {mov dl,[bp+<day]}
  /$B4/$2B               {mov ah,$2B}
  /$CD/$21               {int $21}
);
END;

PROCEDURE PutString(st : String);
BEGIN
Inline(
  $B4/$40                {mov ah,$40}
  /$BB/$01/$00           {mov bx,1}
  /$8A/$8E/>ST           {mov cl,[bp+>st]}
  /$30/$ED               {xor ch,ch}
  /$8D/$96/>ST+1         {lea dx,[bp+>st+1]}
  /$1E                   {push ds}
  /$16                   {push ss}
  /$1F                   {pop ds}
  /$CD/$21               {int $21}
  /$1F                   {pop ds}
);
END;

PROCEDURE UnpackTime(P: Longint; var T: DateTime);
BEGIN
Inline(
  $8B/$56/<P+2           {mov dx,[bp+<p+2]}
  /$C4/$7E/<T            {les di,[bp+<t]}
  /$FC                   {cld}
  /$B9/$09/$00           {mov cx,9}
  /$89/$D0               {mov ax,dx}
  /$D3/$E8               {shr ax,cl}
  /$05/$BC/$07           {add ax,1980}
  /$AB                   {stosw}
  /$B1/$05               {mov cl,5}
  /$89/$D0               {mov ax,dx}
  /$D3/$E8               {shr ax,cl}
  /$25/$0F/$00           {and ax,15}
  /$AB                   {stosw}
  /$89/$D0               {mov ax,dx}
  /$25/$1F/$00           {and ax,31}
  /$AB                   {stosw}
  /$8B/$56/<P            {mov dx,[bp+<p]}
  /$89/$D0               {mov ax,dx}
  /$B1/$0B               {mov cl,11}
  /$D3/$E8               {shr ax,cl}
  /$AB                   {stosw}
  /$89/$D0               {mov ax,dx}
  /$B1/$05               {mov cl,5}
  /$D3/$E8               {shr ax,cl}
  /$25/$3F/$00           {and ax,63}
  /$AB                   {stosw}
  /$89/$D0               {mov ax,dx}
  /$D1/$E0               {shl ax,1}
  /$25/$3F/$00           {and ax,63}
  /$AB                   {stosw}
);
END;

PROCEDURE PackTime(VAR T : DateTime; VAR P: LongInt);
BEGIN
Inline(
  $1E                    {push ds}
  /$C5/$76/<T            {lds si,[bp+<T]}
  /$FC                   {cld}
  /$C4/$7E/<P            {les di,[bp+<P]}
  /$AD                   {lodsw                      ; year}
  /$2D/$BC/$07           {sub ax,1980}
  /$B9/$09/$00           {mov cx,9}
  /$D3/$E0               {shl ax,cl}
  /$89/$C2               {mov dx,ax}
  /$AD                   {lodsw                      ; month}
  /$B1/$05               {mov cl,5}
  /$D3/$E0               {shl ax,cl}
  /$01/$C2               {add dx,ax}
  /$AD                   {lodsw                      ; day}
  /$01/$D0               {add ax,dx}
  /$26/$89/$45/$02       {es: mov [di+2],ax}
  /$AD                   {lodsw                      ; hour}
  /$B1/$0B               {mov cl,11}
  /$D3/$E0               {shl ax,cl}
  /$89/$C2               {mov dx,ax}
  /$AD                   {lodsw                      ; min}
  /$B1/$05               {mov cl,5}
  /$D3/$E0               {shl ax,cl}
  /$01/$C2               {add dx,ax}
  /$AD                   {lodsw                      ; sec}
  /$D1/$E8               {shr ax,1}
  /$01/$D0               {add ax,dx}
  /$AB                   {stosw}
);
END;

PROCEDURE ExecEnv(Path,CmdLine: String; environ : Pointer); EXTERNAL;
{$L ExecEnv.obj}

PROCEDURE Exec(Path,CmdLine: String);
BEGIN
  ExecEnv(Path,CmdLine,NIL);
END;

PROCEDURE SetFAttr(var F; Attr: Word);
BEGIN
Inline(
  $B8/$01/$43            {mov ax,$4301}
  /$1E                   {push ds}
  /$C5/$56/<F            {lds dx,[bp+<f]}
  /$81/$C2/$30/$00       {add dx,48}
  /$8B/$4F/<ATTR         {mov cx,[bx+<attr]}
  /$CD/$21               {int $21}
  /$1F                   {pop ds}
  /$72/$02               {jc g1}
  /$31/$C0               {xor ax,ax}
                         {g1:}
  /$A3/>DOSERROR         {mov [>DosError],ax}
);
END;                                   {SetFAttr}

PROCEDURE GetFAttr(var F; var Attr: Word);
BEGIN
Inline(
  $B8/$00/$43            {mov ax,$4300}
  /$1E                   {push ds}
  /$C5/$56/<F            {lds dx,[bp+<f]}
  /$81/$C2/$30/$00       {add dx,48}
  /$CD/$21               {int $21}
  /$1F                   {pop ds}
  /$72/$02               {jc g1}
  /$31/$C0               {xor ax,ax}
                         {g1:}
  /$A3/>DOSERROR         {mov [>DosError],ax}
  /$C4/$5E/<ATTR         {les bx,[bp+<attr]}
  /$26/$89/$0F           {es: mov [bx],cx}
);
END;                                   {GetFAttr}

PROCEDURE GetDiskInfo(drive : WORD; VAR dinfo : DiskInfo);
BEGIN
Inline(
  $B4/$36                {mov ah,$36}
  /$8A/$56/<DRIVE        {mov dl,[bp+<drive]}
  /$CD/$21               {int $21}
  /$C4/$7E/<DINFO        {les di,[bp+<dinfo]}
  /$26/$89/$1D           {es: mov [di],bx}
  /$26/$89/$55/$02       {es: mov [di+2],dx}
  /$26/$89/$4D/$04       {es: mov [di+4],cx}
  /$26/$89/$45/$06       {es: mov [di+6],ax}
);
END;                                   {GetDiskInfo}

FUNCTION  GetDevStat(handle : WORD) : WORD;
BEGIN
Inline(
  $B8/$00/$44            {mov ax,$4400}
  /$8B/$5E/<HANDLE       {mov bx,[bp+<handle]}
  /$CD/$21               {int $21}
  /$72/$02               {jc g1}
  /$31/$C0               {xor ax,ax}
                         {g1:}
  /$A3/>DOSERROR         {mov [>DosError],ax}
  /$89/$56/$FE           {mov [bp-2],dx}
);
END;                                   {GetDevStat}

PROCEDURE GetTime(VAR hour, min, sec, s100 : WORD);
BEGIN
Inline(
  $B4/$2C                {mov ah,$2C}
  /$CD/$21               {int $21}
  /$31/$C0               {xor ax,ax}
  /$C4/$5E/<HOUR         {les bx,[bp+<hour]}
  /$88/$E8               {mov al,ch}
  /$26/$89/$07           {es: mov [bx],ax}
  /$C4/$5E/<MIN          {les bx,[bp+<min]}
  /$88/$C8               {mov al,cl}
  /$26/$89/$07           {es: mov [bx],ax}
  /$C4/$5E/<SEC          {les bx,[bp+<sec]}
  /$88/$F0               {mov al,dh}
  /$26/$89/$07           {es: mov [bx],ax}
  /$C4/$5E/<S100         {les bx,[bp+<s100]}
  /$88/$D0               {mov al,dl}
  /$26/$89/$07           {es: mov [bx],ax}
);
END;                                   {GetTime}

PROCEDURE GetDate(VAR year, month, day, dow : WORD);
BEGIN
Inline(
  $B4/$2A                {mov ah,$2A}
  /$CD/$21               {int $21}
  /$30/$E4               {xor ah,ah}
  /$C4/$5E/<DOW          {les bx,[bp+<dow]}
  /$26/$89/$07           {es: mov [bx],ax}
  /$C4/$5E/<YEAR         {les bx,[bp+<year]}
  /$26/$89/$0F           {es: mov [bx],cx}
  /$C4/$5E/<MONTH        {les bx,[bp+<month]}
  /$88/$F0               {mov al,dh}
  /$26/$89/$07           {es: mov [bx],ax}
  /$C4/$5E/<DAY          {les bx,[bp+<day]}
  /$88/$D0               {mov al,dl}
  /$26/$89/$07           {es: mov [bx],ax}
);
END;                                   {GetDate}

VAR IntVectorTable : ARRAY [BYTE] OF Pointer ABSOLUTE 0:0;

PROCEDURE GetIntVec(nr : BYTE; VAR p : Pointer);
BEGIN
  p := IntVectorTable[nr];
END;

PROCEDURE SetIntVec(nr : BYTE; p : Pointer);
BEGIN
  InLine($FA);
  IntVectorTable[nr] := p;
  InLine($FB);
END;

PROCEDURE FindFirst(path : String; attr : WORD; VAR dta : SearchRec);
BEGIN
Inline(
  $1E                    {push ds}
  /$C5/$56/<DTA          {lds dx,[bp+<dta]}
  /$B4/$1A               {mov ah,$1A}
  /$CD/$21               {int $21}
  /$16                   {push ss}
  /$1F                   {pop ds}
  /$8D/$96/>PATH         {lea dx,[bp+>path]}
  /$89/$D3               {mov bx,dx}
  /$42                   {inc dx}
  /$8A/$1F               {mov bl,[bx]}
  /$30/$FF               {xor bh,bh}
  /$01/$D3               {add bx,dx}
  /$C6/$07/$00           {mov byte ptr [bx],0}
  /$8B/$4E/<ATTR         {mov cx,[bp+<attr]}
  /$B4/$4E               {mov ah,$4E}
  /$CD/$21               {int $21}
  /$72/$22               {jc done}
  /$C4/$7E/<DTA          {les di,[bp+<dta]}
  /$8E/$5E/<DTA+2        {mov ds,[bp+<dta+2]}
  /$81/$C7/$1E/$00       {add di,30}
  /$30/$C0               {xor al,al}
  /$FC                   {cld}
  /$B9/$FF/$FF           {mov cx,-1}
  /$F2/$AE               {repne scasb}
  /$F7/$D1               {not cx}
  /$49                   {dec cx}
  /$4F                   {dec di}
  /$8D/$75/$FF           {lea si,[di-1]}
  /$FD                   {std}
  /$88/$C8               {mov al,cl}
  /$F2/$A4               {rep movsb}
  /$88/$05               {mov [di],al}
  /$31/$C0               {xor ax,ax}
                         {done:}
  /$1F                   {pop ds}
  /$A3/>DOSERROR         {mov [>DosError],ax}
);
END;                                   {FindFirst}

PROCEDURE FindNext(VAR dta: SearchRec);
BEGIN
Inline(
  $1E                    {push ds}
  /$C5/$56/<DTA          {lds dx,[bp+<dta]}
  /$B4/$1A               {mov ah,$1A}
  /$CD/$21               {int $21}
  /$B4/$4F               {mov ah,$4F}
  /$CD/$21               {int $21}
  /$72/$22               {jc done}
  /$C4/$7E/<DTA          {les di,[bp+<dta]}
  /$8E/$5E/<DTA+2        {mov ds,[bp+<dta+2]}
  /$81/$C7/$1E/$00       {add di,30}
  /$30/$C0               {xor al,al}
  /$FC                   {cld}
  /$B9/$FF/$FF           {mov cx,-1}
  /$F2/$AE               {repne scasb}
  /$F7/$D1               {not cx}
  /$49                   {dec cx}
  /$4F                   {dec di}
  /$8D/$75/$FF           {lea si,[di-1]}
  /$FD                   {std}
  /$88/$C8               {mov al,cl}
  /$F2/$A4               {rep movsb}
  /$88/$05               {mov [di],al}
  /$31/$C0               {xor ax,ax}
                         {done:}
  /$1F                   {pop ds}
  /$A3/>DOSERROR         {mov [>DosError],ax}
);
END;                                   {FindNext}

PROCEDURE GetFTime(VAR fil; VAR time : LongInt);
BEGIN
Inline(
  $B8/$00/$57            {mov ax,$5700}
  /$C4/$5E/<FIL          {les bx,[bp+<fil]}
  /$26/$8B/$1F           {es: mov bx,[bx]}
  /$CD/$21               {int $21}
  /$72/$0C               {jc done}
  /$C4/$5E/<TIME         {les bx,[bp+<time]}
  /$26/$89/$0F           {es: mov [bx],cx}
  /$26/$89/$57/$02       {es: mov [bx+2],dx}
  /$31/$C0               {xor ax,ax}
                         {done:}
  /$A3/>DOSERROR         {mov [>DosError],ax}
);
END;                                   {GetFTime}

PROCEDURE SetFTime(VAR fil; time : LongInt);
BEGIN
Inline(
  $B8/$01/$57            {mov ax,$5701}
  /$C4/$5E/<FIL          {les bx,[bp+<fil]}
  /$26/$8B/$1F           {es: mov bx,[bx]}
  /$8B/$4E/<TIME         {mov cx,[bp+<time]}
  /$8B/$56/<TIME+2       {mov dx,[bp+<time+2]}
  /$CD/$21               {int $21}
  /$72/$02               {jc done}
  /$31/$C0               {xor ax,ax}
                         {done:}
  /$A3/>DOSERROR         {mov [>DosError],ax}
);
END;                                   {SetFTime}

FUNCTION FindEnv(find : String) : String;
VAR st : String;
    cp : ^CHAR;
BEGIN
  cp := Ptr(MemW[PrefixSeg:$2C],0);
  WHILE cp^ <> #0 DO BEGIN
    st := '';
    WHILE cp^ <> #0 DO BEGIN
      Inc(st[0]);
      st[Length(st)] := cp^;
      Inc(WORD(cp));
    END;
    IF Copy(st,1,Length(find)) = find THEN BEGIN
      Delete(st,1,Length(find));
      FindEnv := st;
      Exit;
    END;
    Inc(WORD(cp));
  END;
  FindEnv := '';
END;

END.
<<< timers.pas >>>
{$R-,S-,F+}                                  {No local proc's!}
Unit Timers;

Interface

TYPE
  TimerTablePtr = ^TimerTableRec;
  TimerTableRec = RECORD
    next : TimerTablePtr;
    count : LongInt;
    UserInt, active : BOOLEAN;
  END;

CONST
  TimerPtr : TimerTablePtr = NIL;

VAR SaveExit, OldTimer : Pointer;

PROCEDURE StartTimer(VAR t : TimerTableRec);

PROCEDURE StopTimer(VAR t : TimerTableRec);

FUNCTION  GetTimer(VAR t : TimerTableRec): LongInt;

FUNCTION  RunningTimer(VAR t : TimerTableRec): BOOLEAN;

PROCEDURE GetVector(IntNr : WORD; VAR vector: Pointer);

PROCEDURE SetVector(IntNr : WORD; vector: Pointer);

Implementation

VAR IntVectorTable : ARRAY [0..255] OF Pointer ABSOLUTE 0:0;

PROCEDURE GetVector(IntNr : WORD; VAR vector: Pointer);
BEGIN
  vector := IntVectorTable[IntNr];
END;

PROCEDURE SetVector(IntNr : WORD; vector: Pointer);
BEGIN
  Inline($FA);
  IntVectorTable[IntNr] := vector;
  InLine($FB);
END;

PROCEDURE StopTimer(VAR t : TimerTableRec);
VAR tp, ne : TimerTablePtr;
BEGIN
  t.active := FALSE;
{
  IF TimerPtr = NIL THEN Exit;
  IF TimerPtr = @t THEN BEGIN
    Inline($FA);
    TimerPtr := t.next;
    Inline($FB);
    Exit;
  END;
}
  tp := @TimerPtr;
  ne := TimerPtr;
  WHILE ne <> NIL DO BEGIN
    IF ne = @t THEN BEGIN
      Inline($FA);
      tp^.next := t.next;
      Inline($FB);
      Exit;
    END;
    tp := ne;
    ne := ne^.next;
  END;
END;

PROCEDURE StartTimer(VAR t : TimerTableRec);
BEGIN
  StopTimer(t);
  t.next := TimerPtr;
  t.active := TRUE;
  Inline($FA);
  TimerPtr := @t;
  Inline($FB);
END;

FUNCTION GetTimer(VAR t : TimerTableRec): LongInt;
BEGIN
  Inline($FA);
  GetTimer := t.count;
  Inline($FB);
END;

FUNCTION RunningTimer(VAR t : TimerTableRec): BOOLEAN;
BEGIN
  RunningTimer := t.active;
END;

PROCEDURE Timer_Int; EXTERNAL; {$L timers.obj}

PROCEDURE Exit_Timers;
BEGIN
  SetVector(8,OldTimer);
  ExitProc := SaveExit;
END;

BEGIN
  GetVector(8,OldTimer);
  SetVector(8,@Timer_Int);
  SaveExit := ExitProc;
  ExitProc := @Exit_Timers;
END.