Category : Pascal Source Code
Archive   : TP4KER.ZIP
Filename : TP4KER.PAS

 
Output of file : TP4KER.PAS contained in archive : TP4KER.ZIP


<<< 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 *)
(* bde 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 interrupTP4Kt 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);
IL done;
END
TP4K {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
in al,dx
ENDM

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

InPOfs MACRO ofs
DXofs
in al,dx
ENDM

OutPOfs MACRO ofs
DXofs
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
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 ;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 ;Restart async chip
or [bx.MODEM_Status],al
jmp $+2
InPOfs
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 ;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
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

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 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 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 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 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 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 FAR
intro com
call avail
ax := cx
PasRet

PasProc rs_room 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 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 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/ /$8B/$4E/ /$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/ /$8B/$4E/ /$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; {Br vre 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/ /$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 ] | [RECEIVE] | [GET ');
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/ /$C4/$7E/ /$FC { cld ;}
/$8B/$4E/ /$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/ /$8A/$76/ /$8A/$4E/ /$8A/$6E/ /$B4/$2D {mov ah,$2D}
/$CD/$21 {int $21}
);
END;

PROCEDURE SetDate(year, month, day : WORD);
BEGIN
Inline(
$8B/$4E/ /$8A/$76/ /$8A/$56/ /$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/ /$C4/$7E/ /$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/

/$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/ /$FC {cld}
/$C4/$7E/

/$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/ /$81/$C2/$30/$00 {add dx,48}
/$8B/$4F/ /$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/ /$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/ /$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/ /$CD/$21 {int $21}
/$C4/$7E/ /$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/ /$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/ /$88/$E8 {mov al,ch}
/$26/$89/$07 {es: mov [bx],ax}
/$C4/$5E/ /$88/$C8 {mov al,cl}
/$26/$89/$07 {es: mov [bx],ax}
/$C4/$5E/ /$88/$F0 {mov al,dh}
/$26/$89/$07 {es: mov [bx],ax}
/$C4/$5E/ /$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/ /$26/$89/$07 {es: mov [bx],ax}
/$C4/$5E/ /$26/$89/$0F {es: mov [bx],cx}
/$C4/$5E/ /$88/$F0 {mov al,dh}
/$26/$89/$07 {es: mov [bx],ax}
/$C4/$5E/ /$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/ /$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/ /$B4/$4E {mov ah,$4E}
/$CD/$21 {int $21}
/$72/$22 {jc done}
/$C4/$7E/ /$8E/$5E/ /$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/ /$B4/$1A {mov ah,$1A}
/$CD/$21 {int $21}
/$B4/$4F {mov ah,$4F}
/$CD/$21 {int $21}
/$72/$22 {jc done}
/$C4/$7E/ /$8E/$5E/ /$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/ /$26/$8B/$1F {es: mov bx,[bx]}
/$CD/$21 {int $21}
/$72/$0C {jc done}
/$C4/$5E/