{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}

UNIT tmpcom;

{Version 3.0}

{This unit is the communications port interrupt driver for the IBM-PC.

It handles handles all low-level i/o through the serial port. It is

installed by calling com_install. It deinstalls itself automatically

when the program exits, or you can deinstall it by calling com_deinstall.

Donated to the public domain by Wayne E. Conrad, January, 1989.

If you have any problems or suggestions, please contact me at my BBS:

Pascalaholics Anonymous

(602) 484-9356

2400 bps

The home of WBBS

Lots of source code

}

INTERFACE

USES

Dos;

TYPE

com_parity = (com_none, com_even, com_odd, com_zero, com_one);

{This variable is TRUE if the interrupt driver has been installed, or FALSE

if it hasn't. It's used to prevent installing twice or deinstalling when not

installed.}

CONST

com_installed: Boolean = FALSE;

usefossil:boolean = FALSE;

var

mpcoder:boolean;

mpcode:array[1..6] of byte;

fosport:byte;

regs:registers;

procedure com_flush_rx;

procedure com_flush_tx;

procedure com_purge_tx;

function com_carrier:boolean;

function com_rx:char;

function com_tx_ready:boolean;

function com_tx_empty:boolean;

function com_rx_empty:boolean;

procedure com_tx (ch: Char);

procedure com_tx_string (st: String);

procedure com_lower_dtr;

procedure com_raise_dtr;

procedure com_set_speed(speed:word);

procedure com_set_parity(parity:com_parity; stop_bits:byte);

procedure com_install(portnum:word; var error:word; dofossil:boolean);

procedure com_deinstall;

implementation

{Summary of IBM-PC Asynchronous Adapter Registers. From:

Compute!'s Mapping the IBM PC and PCjr, by Russ Davis

(Greensboro, North Carolina, 1985: COMPUTE! Publications, Inc.),

pp. 290-292.

Addresses given are for COM1 and COM2, respectively. The names given

in parentheses are the names used in this module.

3F8/2F8 (uart_data) Read: transmit buffer. Write: receive buffer, or baud

rate divisor LSB if port 3FB, bit 7 = 1.

3F9/2F9 (uart_ier) Write: Interrupt enable register or baud rate divisor

MSB if port 3FB, bit 7 = 1.

PCjr baud rate divisor is different from other models;

clock input is 1.7895 megahertz rather than 1.8432 megahertz.

Interrupt enable register:

bits 7-4 forced to 0

bit 3 1=enable change-in-modem-status interrupt

bit 2 1=enable line-status interrupt

bit 1 1=enable transmit-register-empty interrupt

bit 0 1=data-available interrupt

3FA/2FA (uart_iir) Interrupt identification register (prioritized)

bits 7-3 forced to 0

bits 2-1 00=change-in-modem-status (lowest)

bits 2-1 01=transmit-register-empty (low)

bits 2-1 10=data-available (high)

bits 2-1 11=line status (highest)

bit 0 1=no interrupt pending

bit 0 0=interrupt pending

3FB/2FB (uart_lcr) Line control register

bit 7 0=normal, 1=address baud rate divisor registers

bit 6 0=break disabled, 1=enabled

bit 5 0=don't force parity

1=if bit 4-3=01 parity always 1

if bit 4-3=11 parity always 0

if bit 3=0 no parity

bit 4 0=odd parity,1=even

bit 3 0=no parity,1=parity

bit 2 0=1 stop bit

1=1.5 stop bits if 5 bits/character or

2 stop bits if 6-8 bits/character

bits 1-0 00=5 bits/character

01=6 bits/character

10=7 bits/character

11=8 bits/character

bits 5..3: 000 No parity

001 Odd parity

010 No parity

011 Even parity

100 No parity

101 Parity always 1

110 No parity

111 Parity always 0

3FC/2FC (uart_mcr) Modem control register

bits 7-5 forced to zero

bit 4 0=normal, 1=loop back test

bits 3-2 all PCs except PCjr

bit 3 1=interrupts to system bus, user-designated output: OUT2

bit 2 user-designated output, OUT1

bit 1 1=activate rts

bit 0 1=activate dtr

3FD/2FD (uart_lsr) Line status register

bit 7 forced to 0

bit 6 1=transmit shift register is empty

bit 5 1=transmit hold register is empty

bit 4 1=break received

bit 3 1=framing error received

bit 2 1=parity error received

bit 1 1=overrun error received

bit 0 1=data received

3FE/2FE (uart_msr) Modem status register

bit 7 1=receive line signal detect

bit 6 1=ring indicator (all PCs except PCjr)

bit 5 1=dsr

bit 4 1=cts

bit 3 1=receive line signal detect has changed state

bit 2 1=ring indicator has changed state (all PCs except PCjr)

bit 1 1=dsr has changed state

bit 0 1=cts has changed state

3FF/2FF (uart_spr) Scratch pad register.}

{Maximum port number (minimum is 1) }

const

max_port = 4;

{Base i/o address for each COM port}

const

uart_base: ARRAY [1..max_port] OF Integer = ($3F8, $2F8, $3E8, $2E8);

{Interrupt numbers for each COM port}

const

intnums: ARRAY [1..max_port] OF Byte = ($0C, $0B, $0C, $0B);

{i8259 interrupt levels for each port}

const

i8259levels: ARRAY [1..max_port] OF Byte = (4, 3, 4, 3);

{UART i/o addresses. Values depend upon which COMM port is selected.}

var

uart_data:word; {Data register}

uart_ier:word; {Interrupt enable register}

uart_iir:word; {Interrupt identification register}

uart_lcr:word; {Line control register}

uart_mcr:word; {Modem control register}

uart_lsr:word; {Line status register}

uart_msr:word; {Modem status register}

uart_spr:word; {Scratch pad register}

{Original contents of IER and MCR registers. Used to restore UART

to whatever state it was in before this driver was loaded.}

var

old_ier:byte;

old_mcr:byte;

{Original contents of interrupt vector. Used to restore the vector when

the interrupt driver is deinstalled.}

var

old_vector:pointer;

{Original contents of interrupt controller mask. Used to restore the

bit pertaining to the comm controller we're using.}

var

old_i8259_mask:byte;

{Bit mask for i8259 interrupt controller}

var

i8259bit:byte;

{Interrupt vector number}

var

intnum:byte;

{ Receive queue. Received characters are held here

until retrieved by com_rx. }

const

rx_queue_size=5120; {Change to suit}

var

rx_queue:array[1..rx_queue_size] of byte;

rx_in:word; {Index of where to store next character}

rx_out:word; {Index of where to retrieve next character}

rx_chars:word; {Number of chars in queue}

{ Transmit queue. Characters to be transmitted are held here

until the UART is ready to transmit them. }

const

tx_queue_size=16; {Change to suit}

var

tx_queue:array[1..tx_queue_size] of byte;

tx_in:integer; {Index of where to store next character}

tx_out:integer; {Index of where to retrieve next character}

tx_chars:integer; {Number of chars in queue}

{This variable is used to save the next link in the "exit procedure" chain.}

var

exit_save:pointer;

{Macro to disable interrupts.}

Procedure disable_interrupts;

Begin

{rcg11172000 not needed under Linux.}

(*

Inline($FA); {CLI}

*)

End;

{Macro to enable interrupts.}

Procedure enable_interrupts;

Begin

{rcg11172000 not needed under Linux.}

(*

Inline($FB); {STI}

*)

End;

{Interrupt driver. The UART is programmed to cause an interrupt whenever

a character has been received or when the UART is ready to transmit another

character.}

{rcg11172000 not needed under Linux.}

{$S-}

(*

procedure com_interrupt_driver; interrupt;

var ch:char;

dummy,iir:byte;

begin

if (usefossil) then exit;

{ while bit 0 of the interrupt identification register is 0,

there is an interrupt to process }

iir:=port[uart_iir];

while (not odd(iir)) do begin

case (iir shr 1) of

{ IIR = 100b: Received data available. Get the character,

and if the buffer isn't full, then save it.

If the buffer is full, then ignore it. }

2:begin

ch:=char(port[uart_data]);

if (rx_chars<=rx_queue_size) then begin

rx_queue[rx_in]:=ord(ch);

inc(rx_in);

if (rx_in>rx_queue_size) then rx_in:=1;

rx_chars:=succ(rx_chars);

end;

end;

{ IIR = 010b: Transmit register empty. If the transmit buffer

is empty, then disable the transmitter to prevent any more

transmit interrupts. Otherwise, send the character.

The test of the line-status-register is to see if the transmit

holding register is truly empty. Some UARTS seem to cause

transmit interrupts when the holding register isn't empty,

causing transmitted characters to be lost. }

1:if (tx_chars<=0) then

port[uart_ier]:=port[uart_ier] and not 2

else

if (odd(port[uart_lsr] shr 5)) then begin

port[uart_data]:=tx_queue[tx_out];

inc(tx_out);

if (tx_out>tx_queue_size) then tx_out:=1;

dec(tx_chars);

end;

{ IIR = 001b: Change in modem status. We don't expect

this interrupt, but if one ever occurs we need to read

the line status to reset it and prevent an endless loop. }

0:dummy:=Port [uart_msr];

{ IIR = 111b: Change in line status. We don't expect

this interrupt, but if one ever occurs we need to read the

line status to reset it and prevent an endless loop. }

3:dummy:=port[uart_lsr];

end;

iir:=port[uart_iir];

end;

{ tell the interrupt controller that we're done with this interrupt }

port[$20]:=$20;

end;

*)

{$S+}

{ flush (empty) the receive buffer. }

procedure com_flush_rx;

var ch:char;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.ah:=$0A;

intr($14,regs);

exit;

end;

disable_interrupts;

}

rx_chars:=0; rx_in:=1; rx_out:=1;

{

enable_interrupts;

}

end;

{ flush (empty) transmit buffer. }

procedure com_flush_tx;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.ah:=$08;

intr($14,regs);

exit;

end;

disable_interrupts;

}

tx_chars:=0; tx_in:=1; tx_out:=1;

{

enable_interrupts;

}

end;

{ purge (empty) transmit buffer. }

procedure com_purge_tx;

begin

{rcg11172000 not needed under Linux.}

{

if (not usefossil) then com_flush_tx else begin

regs.dx:=fosport;

regs.ah:=$09;

intr($14,regs);

end;

}

end;

{ this function returns TRUE if a carrier is present. }

function com_carrier:boolean;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.ah:=$03;

intr($14,regs);

if (regs.ax and $0080) = 0 then

com_carrier:=FALSE

else

com_carrier:=TRUE;

exit;

end;

com_carrier:=((com_installed) and (odd (port[uart_msr] shr 7)));

}

{rcg11172000 temp return:} com_carrier := false;

end;

{ get a character from the receive buffer.

If the buffer is empty, return NULL (#0). }

function com_rx:char;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

if (com_rx_empty) then com_rx:=#0

else begin

regs.dx:=fosport;

regs.ah:=$02;

intr($14,regs);

com_rx:=chr(regs.al);

end;

exit;

end;

if ((not com_installed) or (rx_chars=0)) then

com_rx:=#0

else begin

disable_interrupts;

com_rx:=chr(rx_queue[rx_out]);

inc(rx_out);

if (rx_out>rx_queue_size) then rx_out:=1;

dec(rx_chars);

enable_interrupts;

end;

}

{rcg11172000 temp return:} com_rx := #0;

end;

{ this function returns TRUE if com_tx can accept a character. }

function com_tx_ready: Boolean;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

com_tx_ready:=TRUE;

exit;

end;

com_tx_ready:=((tx_chars<tx_queue_size) or (not com_installed));

}

{rcg11172000 temp return:} com_tx_ready := TRUE;

end;

{ this function returns TRUE if the transmit buffer is empty. }

function com_tx_empty:boolean;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.ah:=$03;

intr($14,regs);

com_tx_empty:=((regs.ax and $4000) <> 0);

exit;

end;

com_tx_empty:=((tx_chars=0) or (not com_installed));

}

{rcg11172000 temp return:} com_tx_empty := TRUE;

end;

{ this function returns TRUE if the receive buffer is empty. }

function com_rx_empty:boolean;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.ah:=$0C;

intr($14,regs);

com_rx_empty:=(regs.ax = $FFFF);

exit;

end;

com_rx_empty:=((rx_chars=0) or (not com_installed));

}

{rcg11172000 temp return:} com_rx_empty := TRUE;

end;

{ send a character. Waits until the transmit buffer isn't full,

then puts the character into it. The interrupt driver will

send the character once the character is at the head of the

transmit queue and a transmit interrupt occurs. }

procedure com_tx(ch:char);

var result:word;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.al:=ord(ch);

regs.ah:=$01;

intr($14,regs);

exit;

end;

if (com_installed) then begin

repeat until (com_tx_ready);

disable_interrupts;

tx_queue[tx_in]:=ord(ch);

if (tx_in<tx_queue_size) then inc(tx_in) else tx_in:=1;

inc(tx_chars);

port[uart_ier]:=port[uart_ier] or 2;

enable_interrupts;

end;

}

end;

{ send a whole string }

procedure com_tx_string(st:string);

var i:byte;

result:word;

begin

{rcg11172000 not needed under Linux.}

{

for i:=1 to length(st) do com_tx(st[i]);

}

end;

{ lower (deactivate) the DTR line. Causes most modems to hang up. }

procedure com_lower_dtr;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.al:=$00;

regs.ah:=$06;

intr($14,regs);

exit;

end;

if (com_installed) then begin

disable_interrupts;

port[uart_mcr]:=port[uart_mcr] and not 1;

enable_interrupts;

end;

}

end;

{ raise (activate) the DTR line. }

procedure com_raise_dtr;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

regs.al:=$01;

regs.ah:=$06;

intr($14,regs);

exit;

end;

if (com_installed) then begin

disable_interrupts;

port[uart_mcr]:=port[uart_mcr] or 1;

enable_interrupts;

end;

}

end;

{ set the baud rate. Accepts any speed between 2 and 65535. However,

I am not sure that extremely high speeds (those above 19200) will

always work, since the baud rate divisor will be six or less, where a

difference of one can represent a difference in baud rate of

3840 bits per second or more. }

procedure com_set_speed (speed: Word);

var divisor:word;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then begin

regs.dx:=fosport;

case speed of

300:regs.al:=(2 shl 5)+3;

600:regs.al:=(3 shl 5)+3;

1200:regs.al:=(4 shl 5)+3;

2400:regs.al:=(5 shl 5)+3;

4800:regs.al:=(6 shl 5)+3;

9600:regs.al:=(7 shl 5)+3;

19200:regs.al:=(0 shl 5)+3;

38400:regs.al:=(1 shl 5)+3;

end;

regs.ah:=$00;

intr($14,regs);

exit;

end;

if (com_installed) then begin

if (speed<2) then speed:=2;

divisor:=115200 div speed;

disable_interrupts;

port[uart_lcr]:=port[uart_lcr] or $80;

portw[uart_data]:=divisor;

port[uart_lcr]:=port[uart_lcr] and not $80;

enable_interrupts;

end;

}

end;

{ Set the parity and stop bits as follows:

com_none 8 data bits, no parity

com_even 7 data bits, even parity

com_odd 7 data bits, odd parity

com_zero 7 data bits, parity always zero

com_one 7 data bits, parity always one }

procedure com_set_parity(parity:com_parity; stop_bits:byte);

var lcr:byte;

begin

{rcg11172000 not needed under Linux.}

{

if (usefossil) then exit;

case parity of

com_none:lcr:=$00 or $03;

com_even:lcr:=$18 or $02;

com_odd:lcr:=$08 or $02;

com_zero:lcr:=$38 or $02;

com_one:lcr:=$28 or $02;

end;

if (stop_bits=2) then lcr:=lcr or $04;

disable_interrupts;

port[uart_lcr]:=port[uart_lcr] and $40 or lcr;

enable_interrupts;

}

end;

{ Install the communications driver. Portnum should be 1..max_port.

Error codes returned are:

0 - No error

1 - Invalid port number

2 - UART for that port is not present

3 - Already installed, new installation ignored }

procedure com_install(portnum:word; var error:word; dofossil:boolean);

var ier:byte;

begin

{rcg11172000 not needed under Linux.}

(*

if ((dofossil) and (not usefossil)) then begin

usefossil:=FALSE;

fosport:=portnum-1;

regs.dx:=fosport;

regs.ah:=$04;

intr($14,regs);

if (regs.ax = $1954) then begin

usefossil:=TRUE;

regs.dx:=fosport;

regs.al:=$F0;

regs.ah:=$0F;

intr($14,regs);

end;

end;

if (usefossil) then exit;

if (com_installed) then error:=3

else

if ((portnum<1) or (portnum>max_port)) then error:=1

else begin

{ set i/o addresses and other hardware specifics for selected port}

uart_data:=uart_base [portnum];

uart_ier:=uart_data+1;

uart_iir:=uart_data+2;

uart_lcr:=uart_data+3;

uart_mcr:=uart_data+4;

uart_lsr:=uart_data+5;

uart_msr:=uart_data+6;

uart_spr:=uart_data+7;

intnum:=intnums[portnum];

i8259bit:=1 shl i8259levels[portnum];

{ return error if hardware not installed }

old_ier:=port[uart_ier];

port[uart_ier]:=0;

if (port[uart_ier]<>0) then error:=2

else begin

error:=0;

{ save original interrupt controller mask, then disable the

interrupt controller for this interrupt. }

disable_interrupts;

old_i8259_mask:=port[$21];

port[$21]:=old_i8259_mask or i8259bit;

enable_interrupts;

{ clear the transmit and receive queues}

com_flush_tx;

com_flush_rx;

{ Save current interrupt vector, then set the interrupt

vector to the address of our interrupt driver. }

getintvec(intnum,old_vector);

setintvec(intnum,@com_interrupt_driver);

com_installed:=TRUE;

{ set parity to none, turn off BREAK signal, and make sure

we're not addressing the baud rate registers. }

port[uart_lcr]:=3;

{ save original contents of modem control register, then enable

interrupts to system bus and activate RTS. Leave DTR the way

it was. }

disable_interrupts;

old_mcr:=port[uart_mcr];

port[uart_mcr]:=$A or (old_mcr and 1);

enable_interrupts;

{ enable interrupt on data-available. The interrupt for

transmit-ready is enabled when a character is put into the

transmit queue, and disabled when the transmit queue is empty. }

port[uart_ier]:=1;

{ enable the interrupt controller for this interrupt. }

disable_interrupts;

port[$21]:=port[$21] and not i8259bit;

enable_interrupts;

end;

end;

*)

end;

{ Deinstall the interrupt driver completely. It doesn't change

the baud rate or mess with DTR; it tries to leave the interrupt

vectors and enables and everything else as it was when the driver

was installed.

This procedure MUST be called by the exit procedure of this

module before the program exits to DOS, or the interrupt driver

will still be attached to its vector -- the next communications

interrupt that came along would jump to the interrupt driver which

is no longer protected and may have been written over. }

procedure com_deinstall;

begin

{rcg11172000 not needed under Linux.}

(*

if (usefossil) then begin

usefossil:=FALSE;

regs.dx:=fosport;

regs.ah:=$05;

intr($14,regs);

exit;

end;

if (com_installed) then begin

com_installed:=FALSE;

{ restore Modem-Control-Register and Interrupt-Enable-Register. }

port[uart_mcr]:=old_mcr;

port[uart_ier]:=old_ier;

{ restore appropriate bit of interrupt controller's mask }

disable_interrupts;

port[$21]:=port[$21] and not i8259bit or old_i8259_mask and i8259bit;

enable_interrupts;

{ reset the interrupt vector }

setintvec(intnum,old_vector);

end;

*)

end;

{ This procedure is called when the program exits for any reason. It

deinstalls the interrupt driver.}

{$F+} procedure exit_procedure; {$F-}

begin

{rcg11172000 not needed under Linux.}

{

com_deinstall;

exitproc:=exit_save;

}

end;

{ This installs the exit procedure. }

begin

{rcg11172000 not needed under Linux.}

{

exit_save:=exitproc;

exitproc:=@exit_procedure;

}

end.