ucl 2.0

# Copyright (c) 2005-2006 by Wayne C. Gramlich
# All rights reserved.

library $pic16f688
library clock16mhz
library $uart
constant $eusart_clock = clock_rate
constant $eusart_factor = 4
library $eusart

configure fosc=hs

#constant $true = 1
#constant $false = 0

package pdip
    pin 1 = power_supply
    pin 2 = osc1
    pin 3 = osc2
    pin 4 = ra3_in, name=dtr
    pin 5 = rx, name=rx
    pin 6 = tx, name=tx
    pin 7 = rc3_out, name=p3
    pin 8 = rc2_out, name=p2
    pin 9 = rc1_in, name=p1
    pin 10 = rc0_in, name=p0
    pin 11 = ra2_out, name=p6
    pin 12 = ra1_in, name=p5
    pin 13 = ra0_out, name=p4
    pin 14 = ground

data_bank 1

# The host buffer lives over in data bank 1:

constant host_buffer_power = 6
constant host_buffer_size = 1 << host_buffer_power
constant host_buffer_mask = host_buffer_size - 1

global host_buffer[host_buffer_size] array[byte]

data_bank 0

global host_index_in byte	# Index to insert bytes into {host_buffer}
global host_index_out byte	# Index to remove bytes from {host_buffer}
global host_count byte		# Number of bytes in host {host_buffer}:

global error bit
global end_of_line bit
global hex_high byte
global hex_low byte
global bus_shift byte
global time_out bit
global bus_msb bit
global bus_buffer[5] array[byte]

origin 0

procedure start
    arguments_none
    returns_nothing
    assemble
	goto main

origin 4

share fsr_save byte		# Place to stuff {$fsr}
share pclath_save byte		# Place to stuff {$pclath}

procedure interrupt
    arguments_none
    returns_nothing

    # This routine will handle a UART receive buffer interrupt.

    # Save {$fsr} and {$pclath}:
    fsr_save := $fsr
    pclath_save := $pclath

    if $rcif
	# Clear the interrupt flag until the next byte arrives:
	$rcif := $false

	# Deal with UART errors:
	if $oerr
	    $cren := $false
	if $ferr
	    $cren := $false
	$cren := $true

	# Now read the byte and stuff it into {host_buffer}:
	host_buffer[host_index_in & host_buffer_mask] := $rcreg
	host_index_in := host_index_in + 1
	host_count := host_count + 1

    # Restore {$pclath} and {$fsr}:
    $pclath := pclath_save
    $fsr := fsr_save


procedure host_byte_get
    arguments_none
    returns byte

    # This routine will wait until {host_buffer} is non-empty and then
    # return the next byte from {host_buffer}.

    local result byte

    # Wait until {host_buffer} has something:
    while host_count = 0
	do_nothing

    # Remove the contents with interrupts turned off:
    $rcif := $false
    result := host_buffer[host_index_out & host_buffer_mask]
    host_index_out := host_index_out + 1
    host_count := host_count - 1
    $rcif := $true

    return result


procedure main
    arguments_none
    returns_nothing

    # This is the main procdure that initializes the the microcontroller
    # and waits for commands from the host.

    local bit9 bit
    local command byte
    local id byte
    local low byte
    local node byte
    local page byte
    local receive byte
    local row byte
    local send byte
    local value byte

    local index byte
    local count byte
    local mask byte
    local ninth bit
    local high4 byte

    # For debugging only -- just wiggle the p2 pin:
    #loop_forever
    #	p2 := $true
    #	p2 := $false

    host_index_in := 0
    host_index_out := 0
    host_count := 0

    # Warm up the EUSART:
    $trisc@5 := $true
    $trisc@4 := $true

    $txsta := 0
    $tx9 := $false
    $txen := $true
    $brgh := $true

    $rcsta := 0
    $spen := $true
    $rx9 := $false
    $cren := $true
    $adden := $true

    $baudctl := 0
    $brg16 := $true

    #$spbrg := $eusart_19200_low
    #$spbrgh := $eusart_19200_highb
    #$spbrg := $eusart_115200_low
    #$spbrgh := $eusart_115200_high
    #$spbrg := $eusart_230400_low
    #$spbrgh := $eusart_230400_high
    #$spbrg := $eusart_460800_low
    #$spbrgh := $eusart_460800_high
    $spbrg := $eusart_500000_low
    $spbrgh := $eusart_500000_high

    # Enable interrupts:
    $rcif := $false
    $rcie := $true
    $peie := $true
    $gie := $true

    # For debugging only -- just output a stream of 'U':
    #loop_forever
    #	loop_exactly 255
    #	    delay 600
    #		do_nothing
    #	call $uart_byte_put('U')

    # For debugging only -- Double echo:
    #loop_forever
    #	# Wait for command:
    #	command := $uart_byte_get()
    #	#call $uart_hex_put(command)
    #  	call $uart_byte_put(command)
    #  	call $uart_byte_put(command)

    # Process commands:
    #call $uart_byte_put('>')
    loop_forever
	# Wait for command:
	error := $false
	end_of_line := $false

	# Fetch a command letter from the user:
	command := host_byte_get()
	if command@7
	    # Binary mode command:
	    switch (command >> 4) & 7
	      case_maximum 7
	      case 0, 1
	        # 100h hhhh (High5 Set):
		ninth := command@4
		high4 := command << 4
	      case 2
	        # 1010 llll (Low4 Send):
		send :=  high4 | command & 0xf
		if ninth
		    call bus_select_send(send)
		else
		    call bus_byte_send(send)
	      case 3
		# 1011 xxxx:
		if command & 0xf = 0
		    # 1011 0000 (Receive5):
		    mask := 0x80
		    count := 0
		    send := 0

		    # Check {bus_buffer} exactly 5 times:
		    loop_exactly 5
			# Check to see if anything is in the {bus_buffer}:
			call shift2(6)
			if !(bus_shift@1)
			    # There is a byte over there:

			    # Stuff the 9th bit into {mask}:
			    if bus_shift@0
				send := send | mask
			    mask := mask >> 1

			    # Grab the rest of the byte:
			    loop_exactly 4
				call shift2(0)
			    bus_buffer[count] := bus_shift
			    count := count + 1
		    send := send | count

		    # Send the results back to the host:
		    call $uart_byte_put(send)
		    if count != 0
			index := 0
			loop_exactly count
			    call $uart_byte_put(bus_buffer[index])
			    index := index + 1
	else
	    # ASCII mode command:

	    # Echo the character:
	    call $uart_byte_put(command)

	    # Convert it to upper case:
	    if 'a' <= command && command <= 'z'
		command := command + ('A' - 'a')
	    if 'A' <= command && command <= 'Z'
		# We have a command letter:
		switch command - 'A'
		  case 'A' - 'A'
		    # Set address:
		    id := hex_byte_get()
		    node := hex_byte_get()
		    if end_of_line_get()
			call $uart_hex_put(id)
			call $uart_space_put()
			call $uart_hex_put(node)
			call $uart_crlf_put()
		  case 'B' - 'A'
		    value := hex_byte_get()
		    if end_of_line_get()
			call $uart_hex_put(value)
			call $uart_crlf_put()
		  case 'C' - 'A'
		    # Clear bus:
		    if end_of_line_get()
			call $uart_crlf_put()
		  case 'D' - 'A'
		    # Deselect:
		    if end_of_line_get()
			call $uart_crlf_put()
			call bus_byte_send(0xff)
			value := bus_byte_receive()
			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)
			call $uart_crlf_put()
		  case 'F' - 'A'
		    # Flush {bus_buffer}:
		    if end_of_line_get()
			time_out := $false
			while !time_out
			    value := bus_byte_receive()
			    call $uart_space_put()
			    if time_out
				call $uart_byte_put('@')
			    else
				call $uart_hex_put(value)
			call $uart_crlf_put()
		  case 'I' - 'A'
		    # Identify:
		    if end_of_line_get()
			call id_dump()
		  case 'J' - 'A'
		    # Jump:
		    call hex_word_get()
		    if end_of_line_get()
			call $uart_hex_put(hex_high)
			call $uart_hex_put(hex_low)
			call $uart_crlf_put()
		  case 'P' - 'A'
		    # Print a page of program memory:
		    page := hex_byte_get()
		    if end_of_line_get()
			row := 0
			low := 0
			while row < 32
			    call $uart_hex_put(page)
			    call $uart_hex_put(low)
			    call $uart_byte_put(':')

			    # Set address:
			    call bus_byte_send(0)
			    call bus_byte_receive()

			    call bus_byte_send(page)
			    call bus_byte_receive()

			    call bus_byte_send(low)
			    call bus_byte_receive()

			    # Read the ack byte:
			    call bus_byte_receive()

			    # Read out 8 words:
			    call bus_byte_send(1)
			    call bus_byte_receive()

			    call bus_byte_send(8)
			    call bus_byte_receive()
			    loop_exactly 8
			        value := bus_byte_receive()
			        call $uart_space_put()
			        if time_out
				    call $uart_byte_put('@')
				else
				    call $uart_hex_put(value)
			        value := bus_byte_receive()
			        if time_out
				    call $uart_byte_put('@')
			        else
				    call $uart_hex_put(value)

			    # Read the ack byte:
			    call bus_byte_receive()

			    call $uart_crlf_put()
			    row := row + 1
			    low := low + 8
		  case 'R' - 'A'
		    # Read:
		    call hex_word_get()
		    if end_of_line_get()
			call $uart_hex_put(hex_high)
			call $uart_hex_put(hex_low)
			call $uart_crlf_put()
		  case 'S' - 'A'
		    # Select:
		    node := hex_byte_get()
		    if end_of_line_get()
			call $uart_crlf_put()
			call bus_select_send(node)
			value := bus_byte_receive()
			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)
			call $uart_byte_put(' ')

			value := bus_byte_receive()
			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)
			call $uart_byte_put(' ')
			value := bus_byte_receive()

			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)
			call $uart_crlf_put()
		  case 'T' - 'A'
		    # Test mode:
		    loop_forever
			call bus_select_send(8)
			loop_exactly 255
			    delay 600
				do_nothing

			call bus_byte_send(command & 0xf)
			command := command + 1
			loop_exactly 255
			    delay 600
				do_nothing
			call $uart_byte_put('.')

		  case 'W' - 'A'
		    # Write:
		    call hex_word_get()
		    value := hex_byte_get()
		    if end_of_line_get()
			call $uart_hex_put(hex_high)
			call $uart_hex_put(hex_low)
			call $uart_hex_put(value)
			call $uart_crlf_put()
		  case 'X' - 'A'
		    # Transmit:
		    value := hex_byte_get()
		    if end_of_line_get()
			#call $uart_hex_put(value)
			#call $uart_crlf_put()
			call bus_byte_send(value)

			value := bus_byte_receive()
			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)
			call $uart_byte_put(' ')

			value := bus_byte_receive()
			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)
			call $uart_byte_put(' ')

			value := bus_byte_receive()
			if time_out
			    call $uart_byte_put('@')
			else
			    if bus_msb
				call $uart_byte_put('1')
			    call $uart_hex_put(value)

			call $uart_crlf_put()
		  case 'Z' - 'A'
		    # Sweep bus looking for modules:
		    if end_of_line_get()
			node := 1
			while node != 0
			    call bus_select_send(node)
			    if bus_byte_receive() = 0xa5
				call $uart_hex_put(node)
				call $uart_byte_put(':')
				call id_dump()
			    node := node + 1
		  default
		    # Command not implemented:
		    call $uart_byte_put('?')
		    call $uart_crlf_put()
	    else_if command = ':'
		# Hex:
		if end_of_line_get()
		    call $uart_crlf_put()
	    else_if command = '\r\'
		# Blank line:
		call $uart_crlf_put()
	    else
		# Illegal command:
		call $uart_byte_put('?')
		call $uart_crlf_put()

	    # Provide a prompt:
	    call $uart_byte_put('>')


procedure id_dump
    arguments_none
    returns_nothing

    # This procedure will print out the id information for the
    # currently selected module.

    local value byte

    # Reset the id index:
    call bus_byte_send(0xfe)

    # Very few modules return the total length right now (just Shaft2);
    # Eventually they all will.  This routine will time-out if nothing
    # is forthcoming.
    value := bus_byte_receive()

    # Read the fixed part:
    loop_exactly 5
	value := bus_byte_send_receive(0xfd)
	call $uart_hex_put(value)
	call $uart_space_put()

		
    # Dump the name string:
    if value & 2 != 0
	call string_dump()

    # Dump the vendor string:
    if value & 1 != 0
	call string_dump()

    call $uart_crlf_put()


procedure string_dump
    arguments_none
    returns_nothing

    # This procedure will dump a string from the id information.

    local length byte

    # We have a vendor string; now read the length:
    call $uart_space_put()
    length := bus_byte_send_receive(0xfd)
    call $uart_hex_put(length)
    call $uart_byte_put(':')

    # Print out the vendor string:
    call $uart_byte_put('"')
    loop_exactly length
	call $uart_byte_put(bus_byte_send_receive(0xfd))
    call $uart_byte_put('"')


procedure bus_byte_send_receive
    argument value byte
    returns byte

    # This procedure will send {value} to the currently selected module
    # and return the response.

    call bus_byte_send(value)
    #call bus_byte_receive()
    return bus_byte_receive()


procedure bus_byte_send
    argument value byte
    returns_nothing

    # This procedure will cause a {value} byte to be sent to the bus.

    #call $uart_byte_put('{')
    loop_exactly 4
	call shift2(value & 3)
	value := value >> 2
    call shift2(4)
    #call $uart_byte_put('}')


procedure bus_select_send
    argument node byte
    returns_nothing

    # This procedure will cause a {node} select byte to be sent.

    loop_exactly 4
	call shift2(node & 3)
	node := node >> 2
    call shift2(5)


procedure bus_byte_receive
    arguments_none
    returns byte

    # This procedure receive a byte from the bus processor.
    # {time_out} is set if no byte is received in a reasonable
    # amount of time.

    #call $uart_byte_put('[')
    time_out := $false
    # Where does 15*20 come from?  This seems to be the minimum
    # timeout that works with programming a PIC16F876.
    loop_exactly 15
	loop_exactly 20
	    call shift2(6)
	    if !(bus_shift@1)
		# We got one:
		bus_msb := $false
		if bus_shift@0
		    bus_msb := $true
		loop_exactly 4
		    call shift2(0)
		#call $uart_byte_put(']')
		return bus_shift
    time_out := $true
    #call $uart_byte_put(']')
    return 0


procedure shift2
    argument value byte
    returns_nothing

    # This procedure will cause 3 bits to be sent to the bus processor
    # and 2 bits returned from the bus processor into {bus_shift}.

    #call $uart_byte_put('<')

    # Set the 3 bits to send up.  The two lower bits are data and
    # the 3rd bit is STROBE.
    p4 := $false
    p3 := $false
    p2 := $false

    if value@2
	p4 := $true
    #	call $uart_byte_put('1')
    #else
    #	call $uart_byte_put('0')
    if value@1
	p3 := $true
    #	call $uart_byte_put('1')
    #else
    #	call $uart_byte_put('0')
    if value@0
	p2 := $true
    #	call $uart_byte_put('1')
    #else
    #	call $uart_byte_put('0')

    # Let the bus processor know that we have some data:
    if p6
	#call $uart_byte_put('L')
	p6 := $false
	# Wait until the bus processor has a response.
	while p5
	    do_nothing
    else
	#call $uart_byte_put('H')
	p6 := $true
	# Wait until the bus processor has a response.
	while !p5
	    do_nothing

    # The bus processor has a response.  Now grab the data.
    bus_shift := bus_shift << 2
    if p1
	bus_shift@1 := $true
    #	call $uart_byte_put('1')
    #else
    #	call $uart_byte_put('0')
    if p0
	bus_shift@0 := $true
    #	call $uart_byte_put('1')
    #else
    #	call $uart_byte_put('0')

    #call $uart_byte_put('>')


procedure character_get
    arguments_none
    returns byte

    # This procedure will get a character from the user and echo it.
    # If the user types '\r\', an extra line feed is output and
    # the global {end_of_line} bit is set.

    local character byte

    character := host_byte_get()
    #character := $uart_byte_get()
    call $uart_byte_put(character)
    if character = '\r\'
	end_of_line := $true
	call $uart_byte_put('\n\')
    return character


procedure end_of_line_get
    arguments_none
    returns bit

    # This procedure will return 1 if end of line has been reached
    # without error; otherwise 0 is returned and an error exclamation
    # point ('!') is output.

    local character byte

    if error
	return 0
    while !end_of_line
	character := character_get()
	if character != '\r\' && character != '\t\' && character != ' '
	    error := $true
	    call $uart_byte_put('!')
	    call $uart_crlf_put()
	    return 0
    return 1


procedure hex_byte_get
    arguments_none
    returns byte

    # This procedure will get a hex byte from the user.  Zero, one or
    # more spaces and tabs may preceed the hex byte.

    call hex_word_get()
    return hex_low


procedure hex_word_get
    arguments_none
    returns_nothing

    # This procedure will get a 16-bit hexadecimal value and return
    # the result in {hex_high} and {hex_low}.

    local character byte
    local digit byte

    hex_high := 0
    hex_low := 0
    character := ' '
    if !end_of_line
	while character = ' ' || character = '\t\'
	    character := character_get()

	loop_forever
	    if '0' <= character && character <= '9'
		digit := character - '0'
	    else_if 'A' <= character && character <= 'F'
		digit := character + (10 - 'A')
	    else_if 'a' <= character && character <= 'f'
		digit := character + (10 - 'a')
	    else_if character = ' ' || character = '\t\' || end_of_line
		return
	    else
		error := $true
		return
	    hex_high := (hex_high << 4) | (hex_low >> 4)
	    hex_low := (hex_low << 4) | digit
	    character := character_get()