'BX-24 Com1 Direct I/O routines
'Filename: BX24Com1DirectIO.bas
'Input routines added by Tom Westhoff 7/28/2003 as
'Modified from "SerialOutString.bas" by Frank Manning
'-------------------------------------------------------------------------------
Option Explicit

' This code allows you to do the equivalent of Debug.Print, except using
' arbitrary baud rates.

' Last mod 12 Oct 2001
'-------------------------------------------------------------------------------

Public Sub Main()
  '.......... Test code ..........
  Const CR As Byte = 13
  Const LF As Byte = 10
  'Specify which routine you need to use
  Const Tx   As Byte = 1  'DebugPrint
  Const Rx   As Byte = 2  'DebugInput or DebugInputByte
  Const TxRx As Byte = 3  'Both
  Dim Char as Byte
  Dim Msg as string
  Dim Wait As Single

  Call UARTsetup(3, 19200)  'This needs to be done only once per program, or when you want to change the baud

  DebugPrint Chr(CR) & Chr(LF)
  DebugPrint "Enter string: "
  Wait = 5.0                       'Can't use a literal constant for the "Wait" parameter
  Msg = DebugInput(Wait)           'Wait 5 seconds before timeout
  DebugPrint Chr(CR) & Chr(LF)
  If Wait < 0.0 Then
    DebugPrint ">>>Timed Out<<<"
  Else
    DebugPrint "Entered: " & msg 
  End If
  DebugPrint Chr(CR) & Chr(LF) & Chr(CR) & Chr(LF)

  DebugPrint "Press 'Enter'"
  DebugPrint " to Quit"
  Do
    DebugPrint Chr(CR) & Chr(LF)
    DebugPrint "Press a key --->"
    Wait = 0.0
    Char = DebugInputByte(Wait)     '0.0 = Wait forever
    DebugPrint " Byte: " & Cstr(Char) & " - " & Chr(Char)
  Loop Until Char = CR
End Sub

'-------------------------------------------------------------------------------
Public Sub UARTsetup(ByVal RxTx as Byte, ByVal Baud as Long)  
  'Configures Com1 UART and sets the desired Baud
  'RxTx can be:
  '1 - Tx (Output) only
  '2 - Rx (Input) only
  '3 - Both Tx & Rx
  If (RxTx < 1) OR (RxTx > 3) Then
    Debug.Print "UARTsetup ERROR=" & Cstr(RxTx)
    Exit Sub
  End If

  'UART Interrupts can NOT be enabled
  'Configure port for 8-bit data, no Tx or Rx interrupt
  RxTx = CByte(NOT(RXTX * 64 + 4))
  Register.UCR = (Register.UCR AND RXTX)

  'Crystal clock frequency (Hz).
  Const fCK As Long = 7372800
  '     Baud    UBRR
  '
  '    2,400     191
  '    4,800      95
  '    9,600      47
  '   14,400      31
  '   19,200      23
  '   28,800      15
  '   38,400      11
  '   57,600       7
  '   76,800       5
  '  115,200       3
  '  153,600       2
  '  230,400       1
  '  480,600       0
  '
  ' In Atmel docs, this equation gives the relationship between the
  ' crystal clock frequency fCK, baud rate and register UBRR value:
  '
  '   Baud = fCK / (16 * (UBRR + 1))
  '
  ' Rearranging terms gives UBRR as a function of fCK and Baud.
  Register.UBRR = CByte( fCK \ (16 * Baud) ) - 1
End Sub

Public Sub DebugPrint(ByVal Tx As String)
  ' Transmits a string from Com1 at the specified baud rate, 8 data bits,
  ' no parity.
  Dim Char As String * 1
  Dim DataByte As Byte
  Dim N As Integer
  Dim Length As Integer

  'Return if nothing to send
  Length = Len(Tx)
  If (Length < 1) Then
    Exit Sub
  End If

  ' UART Transmit Complete.
  Const TXC As Byte = bx0100_0000

  ' Transmit Enable.
  Const TXEN As Byte = bx0000_1000

  ' UART Tx Data Register Empty.
  Const UDRE As Byte = bx0010_0000

  ' Enable transmission.
  Register.UCR = Register.UCR Or TXEN

  ' Clear TXC by writing a 1 to the bit.
  Register.USR = Register.USR Or TXC

  For N = 1 To Length
    Char = Mid(Tx, N, 1)
    DataByte = Asc(Char)

    'Wait for the I/O data register to be available.
    Do Until (Register.USR And UDRE = UDRE)
      Delay(0.0)
    Loop

    'Make the data available for transmission.
    Register.UDR = DataByte
  Next
End Sub

Public Function DebugInputByte (ByRef Wait as Single) as Byte
  'This function waits for a character (Byte) to be received at the Com1 UART
  'Wait is the maximum time in Seconds to wait for a character to be received.
  'If the Wait time is exceeded, Wait is returned as -1.0 and returned value = 0.
  'If Wait is specified as 0.0 then it will NOT time out

  Dim t as Single        'Timeout value
  ' Receive Enable.
  Const RXEN As Byte = bx0001_0000

  ' RXC UART Receive complete flag
  Const RXC As Byte = bx1000_0000

  ' Enable UART reception.
  Register.UCR = Register.UCR Or RXEN

  ' Wait for character to be received.
  t = Timer + Wait          'Initialize timer
  Do Until (Register.USR And RXC = RXC)
    If Wait > 0.0 then      'Don't timeout if 0.0 was specified
      If Timer > t then
        Wait = -1.0
        DebugInputByte = 0
        Exit Function
      End IF
    End If
    Delay(0.0)              'Allow other processes to run
  Loop

  'Get the Byte 
  DebugInputByte = Register.UDR
End Function

Public Function DebugInput(ByRef Wait as Single) as String
  Const CR As Byte = 13
  Dim Char as Byte
  Dim Msg as String
  msg = ""
  Do
    Char = DebugInputByte(Wait)
    If (Char = CR) OR (Wait < 0.0) Then 
      DebugInput = Msg 
      Exit Function
    Else
      DebugPrint Chr(Char)
      Msg = Msg & Chr(Char)
    End If
  Loop
End Function
'-------------------------------------------------------------------------------