\ Ethernet driver for TM4C1294 contributed by Bernd Paysan
\   needs basisdefinitions.txt

compiletoflash

\ -----------------------------------------------
\ Real Time Clock with on-board 32768 Hz crystal
\ -----------------------------------------------

$400FC000 constant HIBRTCC    \ Hibernation RTC Counter
$400FC004 constant HIBRTCM0   \ Hibernation RTC Match 0
$400FC00C constant HIBRTCLD   \ Hibernation RTC Load
$400FC010 constant HIBCTL     \ Hibernation Control
$400FC014 constant HIBIM      \ Hibernation Interrupt Mask
$400FC018 constant HIBRIS     \ Hibernation Raw Interrupt Status
$400FC01C constant HIBMIS     \ Hibernation Masked Interrupt Status
$400FC020 constant HIBIC      \ Hibernation Interrupt Clear
$400FC024 constant HIBRTCT    \ Hibernation RTC Trim
$400FC028 constant HIBRTCSS   \ Hibernation RTC Sub Seconds

: RTC-Wait ( -- ) begin $80000000 HIBCTL bit@ until ;

: RTC-Init ( Seconds -- )
    $10 HIBIM ! \ Enable WC interrupt
    $40 HIBCTL ! \ Enable oscillator input
    begin $10 HIBMIS bit@ until \ Wait for the WC interrupt to trigger - clock is stable afterwards
    $10 HIBIC !    \ Clear WC interrupt
    0 HIBIM !       \ Disable WC interrupt

    RTC-Wait
    $41 HIBCTL ! \ Enable real time clock
;

: setseconds ( seconds -- ) RTC-Wait HIBRTCLD ! RTC-Wait ;
: seconds    ( -- seconds ) HIBRTCC @ inline ;

\ -----------------------------------------------------------
\   Cooperative Multitasking
\ -----------------------------------------------------------

\ Configuration:

128 cells constant stackspace \ 128 stack elements for every task

\ Internal stucture of task memory:
\  0: Pointer to next task
\  4: Task currently active ?
\  8: Saved stack pointer
\ 12: Handler for Catch/Throw
\  Parameter stack space
\  Return    stack space

false 0 true flashvar-here 4 cells - 4 nvariable boot-task \ Boot task is active, without handler and has no extra stackspace.
boot-task boot-task ! \ For compilation into RAM only

boot-task variable up \ User Pointer
: next-task  ( -- task )    up @ inline ;
: task-state ( -- state )   up @ 1 cells + inline ;
: save-task  ( -- save )    up @ 2 cells + inline ;
: handler    ( -- handler ) up @ 3 cells + inline ;

: (pause) ( stacks fly around )
    [ $B430 h, ]        \ push { r4  r5 } to save I and I'
    rp@ sp@ save-task !  \ save return stack and stack pointer
    begin
      next-task @ up !     \ switch to next running task
    task-state @ until
    save-task @ sp! rp!  \ restore pointers
    unloop ;              \ pop { r4  r5 } to restore the loop registers

: wake ( task -- ) 1 cells +  true swap ! ; \ Wake a random task (IRQ save)
: idle ( task -- ) 1 cells + false swap ! ;  \ Idle a random task (IRQ save)

\ -------------------------------------------------------
\  Round-robin list task handling - do not use in IRQ !
\ -------------------------------------------------------

: stop ( -- ) false task-state ! pause ; \ Stop current task
: multitask  ( -- ) ['] (pause) hook-pause ! ;
: singletask ( -- ) [']  nop    hook-pause ! ;

: task-in-list? ( task -- ? ) \ Checks if a task is currently inside of round-robin list (do not use in IRQ)
  next-task
  begin
    ( Task-Address )
    2dup = if 2drop true exit then
    @ dup next-task = \ Stop when end of circular list is reached
  until
  2drop false
;

: previous ( task -- addr-of-task-before )
  \ Find the task that has the desired one in its next field
  >r next-task begin dup @ r@ <> while @ repeat rdrop
;

: insert ( task -- ) \ Insert a task into the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if drop else next-task @ over ! next-task ! then
;

: remove ( task -- ) \ Remove a task from the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if dup @ ( task next )
     swap previous ( next previous ) !
  else drop then
;

\ -----------------------------------------
\ Create a new task - do not use in IRQ !
\ -----------------------------------------

: task: ( "name" -- )  stackspace cell+ 2*  4 cells +  buffer: ;

: preparetask ( task continue -- )
  swap >r ( continue R: task )

    \ true  r@ 1 cells + ! \ Currently running
      false r@ 3 cells + ! \ No handler

    r@ 4 cells + stackspace + ( continue start-of-parameter-stack )
      dup   r@ 2 cells + ! \ Start of parameter stack

    dup stackspace + ( continue start-of-parameter-stack start-of-return-stack )
    tuck      ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack )
    2 cells - ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack* ) \ Adjust for saved loop index and limit
    swap  !   ( continue start-of-return-stack ) \ Store the adjusted return stack pointer into the parameter stack
    !         \ Store the desired entry address at top of the tasks return stack

  r> insert
;

: activate ( task --   R: continue -- )
  true over 1 cells + ! \ Currently running
  r> preparetask
;

: background ( task --   R: continue -- )
  false over 1 cells + ! \ Currently idling
  r> preparetask
;

\ --------------------------------------------------
\  Multitasking insight
\ --------------------------------------------------

: tasks ( -- ) \ Show tasks currently in round-robin list
  hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.

  \ Start with current task.
  next-task cr

  begin
    ( Task-Address )
    dup             ." Task Address: " hex.
    dup           @ ." Next Task: " hex.
    dup 1 cells + @ ." State: " hex.
    dup 2 cells + @ ." Stack: " hex.
    dup 3 cells + @ ." Handler: " hex. cr

    @ dup next-task = \ Stop when end of circular list is reached
  until
  drop

  hook-pause ! \ Restore old state of multitasking
;

\ --------------------------------------------------
\  Exception handling
\ --------------------------------------------------

: catch ( x1 .. xn xt -- y1 .. yn throwcode / z1 .. zm 0 )
    [ $B430 h, ]  \ push { r4  r5 } to save I and I'
    sp@ >r handler @ >r rp@ handler !  execute
    r> handler !  rdrop  0 unloop ;

: throw ( throwcode -- )  dup IF
        handler @ 0= IF false task-state ! THEN \ unhandled error: stop task
        handler @ rp! r> handler ! r> swap >r sp! drop r>
        UNLOOP  EXIT
    ELSE  drop  THEN ;

\ --------------------------------------------------
\  Ethernet drivers
\ --------------------------------------------------

$400EC000 constant Ethernet-Base
$400FE000 constant USB-Base \ for unique device ID

USB-Base $F20 + Constant UNIQUEID0
USB-Base $F24 + Constant UNIQUEID1
USB-Base $F28 + Constant UNIQUEID2
USB-Base $F2C + Constant UNIQUEID3

\ Ethernet MAC (Ethernet Offset)
Ethernet-Base $000 + constant EMACCFG       \ RW $0000.8000 Ethernet MAC Configuration
Ethernet-Base $004 + constant EMACFRAMEFLTR \ RW $0000.0000 Ethernet MAC Frame Filter
Ethernet-Base $008 + constant EMACHASHTBLH  \ RW $0000.0000 Ethernet MAC Hash Table High
Ethernet-Base $00C + constant EMACHASHTBLL  \ RW $0000.0000 Ethernet MAC Hash Table Low
Ethernet-Base $010 + constant EMACMIIADDR   \ RW $0000.0000 Ethernet MAC MII Address
Ethernet-Base $014 + constant EMACMIIDATA   \ RW $0000.0000 Ethernet MAC MII Data Register
Ethernet-Base $018 + constant EMACFLOWCTL   \ RW $0000.0000 Ethernet MAC Flow Control
Ethernet-Base $01C + constant EMACVLANTG    \ RW $0000.0000 Ethernet MAC VLAN Tag
Ethernet-Base $024 + constant EMACSTATUS    \ RO $0000.0000 Ethernet MAC Status
Ethernet-Base $028 + constant EMACRWUFF     \ RW $0000.0000 Ethernet MAC Remote Wake-Up Frame Filter
Ethernet-Base $02C + constant EMACPMTCTLSTAT \ RW $0000.0000 Ethernet MAC PMT Control and Status Register

Ethernet-Base $038 + constant EMACRIS       \ RO $0000.0000 Ethernet MAC Raw Interrupt Status
Ethernet-Base $03C + constant EMACIM        \ RW $0000.0000 Ethernet MAC Interrupt Mask

Ethernet-Base $040 + constant EMACADDR0H    \ RW $8000.FFFF Ethernet MAC Address 0 High
Ethernet-Base $044 + constant EMACADDR0L    \ RW $FFFF.FFFF Ethernet MAC Address 0 Low Register
Ethernet-Base $048 + constant EMACADDR1H    \ RW $0000.FFFF Ethernet MAC Address 1 High
Ethernet-Base $04C + constant EMACADDR1L    \ RW $FFFF.FFFF Ethernet MAC Address 1 Low
Ethernet-Base $050 + constant EMACADDR2H    \ RW $0000.FFFF Ethernet MAC Address 2 High
Ethernet-Base $054 + constant EMACADDR2L    \ RW $FFFF.FFFF Ethernet MAC Address 2 Low
Ethernet-Base $058 + constant EMACADDR3H    \ RW $0000.FFFF Ethernet MAC Address 3 High
Ethernet-Base $05C + constant EMACADDR3L    \ RW $FFFF.FFFF Ethernet MAC Address 3 Low

Ethernet-Base $0DC + constant EMACWDOGTO    \ RW $0000.0000 Ethernet MAC Watchdog Timeout

Ethernet-Base $100 + constant EMACMMCCTRL   \ RW $0000.0000 Ethernet MAC MMC Control
Ethernet-Base $104 + constant EMACMMCRXRIS  \ RO $0000.0000 Ethernet MAC MMC Receive Raw Interrupt Status
Ethernet-Base $108 + constant EMACMMCTXRIS  \ R  $0000.0000 Ethernet MAC MMC Transmit Raw Interrupt Status
Ethernet-Base $10C + constant EMACMMCRXIM   \ RW $0000.0000 Ethernet MAC MMC Receive Interrupt Mask
Ethernet-Base $110 + constant EMACMMCTXIM   \ RW $0000.0000 Ethernet MAC MMC Transmit Interrupt Mask

Ethernet-Base $118 + constant EMACTXCNTGB   \ RO $0000.0000 Ethernet MAC Transmit Frame Count for Good and Bad Frames
Ethernet-Base $14C + constant EMACTXCNTSCOL \ RO $0000.0000 Ethernet MAC Transmit Frame Count for Frames Transmitted after Single Collision
Ethernet-Base $150 + constant EMACTXCNTMCOL \ RO $0000.0000 Ethernet MAC Transmit Frame Count for Frames Transmitted after Multiple Collisions
Ethernet-Base $164 + constant EMACTXOCTCNTG \ RO $0000.0000 Ethernet MAC Transmit Octet Count Good
                                    
Ethernet-Base $180 + constant EMACRXCNTGB      \ RO $0000.0000 Ethernet MAC Receive Frame Count for Good and Bad Frames
Ethernet-Base $194 + constant EMACRXCNTCRCERR  \ RO $0000.0000 Ethernet MAC Receive Frame Count for CRC Error Frames
Ethernet-Base $198 + constant EMACRXCNTALGNERR \ RO $0000.0000 Ethernet MAC Receive Frame Count for Alignment Error Frames
Ethernet-Base $1C4 + constant EMACRXCNTGUNI    \ RO $0000.0000 Ethernet MAC Receive Frame Count for Good Unicast Frames

Ethernet-Base $584 + constant EMACVLNINCREP   \ RW $0000.0000 Ethernet MAC VLAN Tag Inclusion or Replacement
Ethernet-Base $588 + constant EMACVLANHASH    \ RW $0000.0000 Ethernet MAC VLAN Hash Table
Ethernet-Base $700 + constant EMACTIMSTCTRL   \ RW $0000.2000 Ethernet MAC Timestamp Control
Ethernet-Base $704 + constant EMACSUBSECINC   \ RW $0000.0000 Ethernet MAC Sub-Second Increment

Ethernet-Base $708 + constant EMACTIMSEC      \ RO $0000.0000 Ethernet MAC System Time - Seconds
Ethernet-Base $70C + constant EMACTIMNANO     \ RO $0000.0000 Ethernet MAC System Time - Nanoseconds
Ethernet-Base $710 + constant EMACTIMSECU     \ RW $0000.0000 Ethernet MAC System Time - Seconds Update
Ethernet-Base $714 + constant EMACTIMNANOU    \ RW $0000.0000 Ethernet MAC System Time - Nanoseconds Update
Ethernet-Base $718 + constant EMACTIMADD      \ RW $0000.0000 Ethernet MAC Timestamp Addend
Ethernet-Base $71C + constant EMACTARGSEC     \ RW $0000.0000 Ethernet MAC Target Time Seconds
Ethernet-Base $720 + constant EMACTARGNANO    \ RW $0000.0000 Ethernet MAC Target Time Nanoseconds
Ethernet-Base $724 + constant EMACHWORDSEC    \ RW $0000.0000 Ethernet MAC System Time-Higher Word Seconds
Ethernet-Base $728 + constant EMACTIMSTAT     \ RO $0000.0000 Ethernet MAC Timestamp Status

Ethernet-Base $72C + constant EMACPPSCTRL     \ RW $0000.0000 Ethernet MAC PPS Control
Ethernet-Base $760 + constant EMACPPS0INTVL   \ RW $0000.0000 Ethernet MAC PPS0 Interval
Ethernet-Base $764 + constant EMACPPS0WIDTH   \ RW $0000.0000 Ethernet MAC PPS0 Width

Ethernet-Base $C00 + constant EMACDMABUSMOD   \ RW $0002.0101 Ethernet MAC DMA Bus Mode
Ethernet-Base $C04 + constant EMACTXPOLLD     \ WO $0000.0000 Ethernet MAC Transmit Poll Demand
Ethernet-Base $C08 + constant EMACRXPOLLD     \ WO $0000.0000 Ethernet MAC Receive Poll Demand
Ethernet-Base $C0C + constant EMACRXDLADDR    \ RW $0000.0000 Ethernet MAC Receive Descriptor List Address
Ethernet-Base $C10 + constant EMACTXDLADDR    \ RW $0000.0000 Ethernet MAC Transmit Descriptor List Address
Ethernet-Base $C14 + constant EMACDMARIS      \ RW $0000.0000 Ethernet MAC DMA Interrupt Status
Ethernet-Base $C18 + constant EMACDMAOPMODE   \ RW $0000.0000 Ethernet MAC DMA Operation Mode
Ethernet-Base $C1C + constant EMACDMAIM       \ RW $0000.0000 Ethernet MAC DMA Interrupt Mask Register
                                      
Ethernet-Base $C20 + constant EMACMFBOC     \ RO  $0000.0000 Ethernet MAC Missed Frame and Buffer Overflow Counter
Ethernet-Base $C24 + constant EMACRXINTWDT  \ RW  $0000.0000 Ethernet MAC Receive Interrupt Watchdog Timer
Ethernet-Base $C48 + constant EMACHOSTXDESC \  R  $0000.0000 Ethernet MAC Current Host Transmit Descriptor
Ethernet-Base $C4C + constant EMACHOSRXDESC \ RO  $0000.0000 Ethernet MAC Current Host Receive Descriptor
Ethernet-Base $C50 + constant EMACHOSTXBA   \  R  $0000.0000 Ethernet MAC Current Host Transmit Buffer Address
Ethernet-Base $C54 + constant EMACHOSRXBA   \  R  $0000.0000 Ethernet MAC Current Host Receive Buffer Address
Ethernet-Base $FC0 + constant EMACPP        \ RO  $0000.0103 Ethernet MAC Peripheral Property Register
Ethernet-Base $FC4 + constant EMACPC        \ RW  $0080.040E Ethernet MAC Peripheral Configuration Register
Ethernet-Base $FC8 + constant EMACCC        \ RO  $0000.0000 Ethernet MAC Clock Configuration Register
Ethernet-Base $FD0 + constant EPHYRIS       \ RO  $0000.0000 Ethernet PHY Raw Interrupt Status
Ethernet-Base $FD4 + constant EPHYIM        \ RW  $0000.0000 Ethernet PHY Interrupt Mask
Ethernet-Base $FD8 + constant EPHYMISC      \ RW  $0000.0000 Ethernet PHY Masked Interrupt Status and Clear

 
\ Constants for EMACDMAIM
1 16 lshift constant NIE
1  6 lshift constant RIE

\ -----------------------------------------------
\  Definitions for Buffers and Descriptors
\ -----------------------------------------------

1 31 lshift constant own

1524 Constant ether-size \ aligned to 4

ether-size buffer: RX-Puffer-0
ether-size buffer: RX-Puffer-1
ether-size buffer: RX-Puffer-2
ether-size buffer: RX-Puffer-3
ether-size buffer: RX-Puffer-4
ether-size buffer: RX-Puffer-5
ether-size buffer: RX-Puffer-6
ether-size buffer: RX-Puffer-7
ether-size buffer: TX-Puffer
ether-size buffer: TX-Puffer-2

1 15 lshift constant RER

8 4 * Constant desc-size
8 Constant descs# \ reserve 8 descriptors
8 Constant txdescs# \ reserve 2 descriptors
desc-size descs# * 1- Constant descs-mask
desc-size txdescs# * 1- Constant txdescs-mask

1 30 lshift constant IC
1 29 lshift constant LS  \ Last Segment of Frame
1 28 lshift constant FS  \ First Segment of Frame
1 25 lshift constant TTSE \ time stamp enable
3 22 lshift constant CIC:cs \ IP header checksum insertion
1 21 lshift constant TER \ Transmit End of Ring
1 17 lshift constant TTSS \ time stamp status

LS FS or TTSE or CIC:cs or TTSS or Constant TDES0
TDES0 own or Constant TDES0:own

2 29 lshift constant SAIC:RS \ replace source

0 Variable rx-head \ descriptor to add new buffers
0 Variable rx-tail \ descriptor to receive buffers
0 Variable tx-head \ descriptor to send new buffers

desc-size descs# * buffer: RX-Descriptors
desc-size txdescs# * buffer: TX-Descriptors

: RX-Descriptor   RX-Descriptors rx-head @ + ;
: RX-Descriptor'  RX-Descriptors rx-tail @ + ;
: TX-Descriptor   TX-Descriptors tx-head @ + ;
: TX-Descriptor'  TX-Descriptors tx-head @ desc-size - txdescs-mask and + ;


\ -----------------------------------------------
\  IP, UDP and other protocol fields
\ -----------------------------------------------

: bounds ( addr len -- end start ) over + swap inline 2-foldable ;
: +field ( offset size "name" -- )  <builds over , + does> @ + ;
: cfield: ( u1 "name" -- u2 )  1 +field ;
: field: ( u1 "name" -- u2 )   aligned 1 cells +field ;

\ IP header offsets

0
6 +field eth-dest
6 +field eth-src
2 +field eth-type
dup Constant ether-header#
1 +field ip-version
1 +field ip-tos
2 +field ip-len
2 +field ip-id
2 +field ip-frag
1 +field ip-ttl
1 +field ip-protocol
2 +field ip-hdrcs
4 +field ip-src
4 +field ip-dest
dup Constant ip-header#
2 +field udp-src
2 +field udp-dest
2 +field udp-len
2 +field udp-cs
Constant udp-header#
ip-header#
1 +field icmp-type
1 +field icmp-code
2 +field icmp-cs
Constant icmp-header#


\ -----------------------------------------------
\  Insight into wild packets coming in
\ -----------------------------------------------

: netstat ( -- )
  ." Incoming frames: " EMACRXCNTGB @ u. cr
  ." Outgoing frames: " EMACTXCNTGB @ u. cr
;

: byte. ( u -- )
  base @ hex swap
  0 <# # # #> type
  base !
;

: word. ( u -- )
  base @ hex swap
  0 <# # # # # #> type
  base !
;

: mac. ( addr -- )
  dup     c@ byte. ." :"
  dup 1 + c@ byte. ." :"
  dup 2 + c@ byte. ." :"
  dup 3 + c@ byte. ." :"
  dup 4 + c@ byte. ." :"
      5 + c@ byte. space
;

: packetdump ( addr len )
  0 ?do ( addr )
      i $7 and 0= if space then \ Alle 8 Zeichen ein zusätzliches Leerzeichen
      i $F and 0= if cr then  \ Alle 16 Zeichen einen Zeilenumbruch
      dup i + c@ byte. space
    loop
  drop
  cr
;

: .packet ( addr len -- )
    singletask
    dup ." Länge " u.
    over eth-dest ." Ziel-MAC "  mac.
    over eth-src  ." Quell-MAC " mac.
    ." Ethertype " over eth-type dup c@ byte. 1+ c@ byte. cr
    
    ( length addr )
    packetdump
    multitask
;

: .send ( -- ) singletask
     ." Outgoing: " cr
    ." EMACDMARIS: "  emacdmaris @ hex. cr
    TX-Descriptor' cell+ 2@ $3FFF and .packet
;

\ -----------------------------------------------
\  MAC and routing essentials
\ -----------------------------------------------

1 5 lshift constant UNF \ Transmit Underflow
1 2 lshift constant TU \ Transmit Unavailable

create mymac  
$00 c, 
$1A c, 
$B6 c, 
uniqueid0 @ dup c, 
8 rshift c, 
uniqueid3 3 + c@ c, 
$00 c, 
$80 c,  \ use unique ID

mymac 5 + c@ 24 lshift 10 +
Variable myip \ in network byte order   

3 cells buffer: routing \ router addr, subnet mask, broadcast address

: tc, ( addr char -- addr' )  over c! 1+ ;
: tw, ( addr word -- addr' )  >r r@ 8 rshift tc, r> tc, ;
: tl, ( addr word -- addr' )  >r r@ $10 rshift tw, r> tw, ;
: t$, ( addr addr1 u1 -- addr' ) rot 2dup + >r swap move r> ;
: tz, ( addr u -- addr' ) 2dup 0 fill + ;

: ffmac, ( addr -- addr' )   6 0 DO  $FF tc,  LOOP ;


\ -----------------------------------------------
\  Send and receive packets
\ -----------------------------------------------

: tx-buffer+ ( addr u -- )
    \ send this block
    SAIC:RS or TX-Descriptor cell+ 2! \ TDES1+2: Puffergröße+Addr und ein paar Flags
    TDES0:own
    tx-head @ desc-size + txdescs-mask u>= TER and or
    TX-Descriptor ! \ TDES0: Zum Abschicken an den DMA übergeben
    unf tu or emacdmaris !    \ Transmit Buffer Underflow löschen
    -1 EMACTXPOLLD ! \ polltx to tell TX logic to go on
    tx-head @ desc-size + txdescs-mask and tx-head !
;   \ Sendelogik anstuppsen

: tx-buffer+2 ( addrhdr uhdr addrdata udata -- )
    \ send these two blocks, one is a prefabbed header, the other dynamic data
    16 lshift rot or swap TX-Descriptor 3 cells + ! \ TDES3: Addr2
    tx-buffer+ ;

: rx-buffer+ ( addr u -- )
    ether-size min \ no more than 1522 bytes
    own RX-Descriptor !
    rx-head @ desc-size + descs-mask u>= RER and or
    RX-Descriptor cell+ 2!
    rx-head @ desc-size + descs-mask and rx-head !
    -1 EMACRXPOLLD ! ;

\ ---------------------------------------------------
\  Prepare the handler for incoming ethernet frames
\ ---------------------------------------------------

task: ethernet-task

: ethernet-handler ( -- )
    -1 EMACDMARIS ! ;

: rx-tail+ ( -- ) rx-tail @ desc-size + descs-mask and rx-tail ! ;

: desc@ ( desc -- addr u )
    >r r@ 8 + @ r> @ 16 rshift $3FFF and ;

: dump-rx ( desc -- ) desc@ .packet cr ;

: rx-ipv6 ( desc -- )
    ." IPv6 packet received" cr dump-rx ;

\ -----------------------------------------------
\  Address Resolution Protocol
\ -----------------------------------------------

\ arp protocol: reply to requests (no caching and doing our own requests)

10 constant /arp
16 constant arp-cache#
/arp arp-cache# * buffer: arp-cache
0 Variable arp#
: arp-cache+ ( addr u -- )
    arp-cache arp# @ + swap move
    /arp arp# @ + dup /arp arp-cache# * u< and arp# ! ;
: ip>mac ( ip-addr -- macaddr/0 ) \ look up MAC for IP in ARP cache
    arp-cache /arp arp-cache# * bounds DO
	dup i 6 + @ = IF  drop I  UNLOOP  EXIT  THEN
    /arp +LOOP  drop 0 ;

: >reply ( addr u -- addr u )
    over dup 6 + swap 6 move ;

: rx-arp ( desc -- ) desc@ over ether-header# + >r
    r@ 2@ $01000406 $00080100 d= \ is it an arp request?
    IF  myip @ r@ 24 + @ =       \ is it actually for our IP?
	IF \ arp request for us: do in-place reply
	    >reply  r> 7 + 2 tc,     \ set reply flag
	    dup dup 10 + 10 move     \ move request tuple to reply tuple
	    mymac 6 t$, myip 4 t$,   \ set my mac
	    2drop 42 tx-buffer+ EXIT \ reply it
	THEN
	rdrop 2drop EXIT \ not my IP
    THEN
    r@ 2@ $02000406 $00080100 d= \ is it an arp reply?
    IF
	2drop r> 8 + 10 arp-cache+  EXIT
    THEN
    ." ARP unknown packet received " r@ 2@ hex. hex. cr
    rdrop .packet cr ;

: fill-arp1 ( -- ) \ generic ARP request
    TX-Puffer
    \ Ziel-MAC-Adresse, Broadcast
    ffmac,
    \ Quell-MAC-Adresse, wird ersetzt
    ffmac,

    \ Ethertype: ARP
    $0806 tw,
    \ Rest im Puffer: ARP-Request, damit wir auch eine Antwort kriegen
    1 tw, $800 tw, $06040001 tl,
    \ my mac     my ip       my mac       my ip
    mymac 6 t$,  myip 4 t$, ;

: grat-arp ( -- ) \ Send Packet
    \ fill buffer with gratious arp information
    fill-arp1  mymac 6 t$,  myip 4 t$,  drop
    TX-Puffer 42 tx-buffer+ ;

: req-arp ( ip-addr -- ) >r
    fill-arp1  ffmac,  r> tl,  drop
    TX-Puffer 42 tx-buffer+ ;

\ -----------------------------------------------
\  IP header debugging
\ -----------------------------------------------

: be-w@ ( addr -- w )  count >r c@ r> 8 lshift or ;
: be-w! ( w addr -- )  over 8 rshift over c! 1+ c! ;
: be-l@ ( addr -- l )  count >r count >r count >r c@
    r> 8 lshift or  r> 16 lshift or r> 24 lshift or ;
: be-l! ( l addr -- ) \ store l in network byte order
    over 16 rshift over be-w!  2 + be-w! ;
: w>< ( x' -- x' ) \ swap two bytes be/le
    dup 8 lshift swap 8 rshift $FF and or $FFFF and ;
: l>< ( x -- x' ) \ swap four bytes be/le
    dup 16 rshift w>< swap w>< 16 lshift or ;

: .iphdr ( addr len -- addr len )  singletask
    ." IP packet received" cr
    ." Ethernet length: " dup >r . cr
    ." IP length: " dup ip-len be-w@ . cr
    ." IP type: " dup ip-protocol c@ . cr
    r> ;

: .ippacket ( addr len -- )  .iphdr .packet cr ;


\ -----------------------------------------------
\  IP Routing
\ -----------------------------------------------

: ip>lan ( ip -- ip' ) \ if routable, replace by default GW
    dup routing 2@ over and >r and r> <> IF
	drop routing @
    THEN ;

Create ip-hdr-template
$FF c, $FF c, $FF c, $FF c, $FF c, $FF c, \ will be replaced with my mac
$08 c, $00 c, \ protocol: IP
$45 c, $00 c, $00 c, $00 c, \ ip-version, ip-tos, ip-len
$00 c, $00 c, $40 c, $00 c, \ ip-id, ip-frag
$40 c, $00 c, $00 c, $00 c, \ ip-ttl, ip-protocol, ip-checksum

$8000 variable udp-myport# \ user-specified ports...

: ip-socket ( ip addr -- ) >r
    ip-hdr-template r@ 6 +  20 move \ default flags
    myip @ r@ ip-src !
    l>< dup r@ ip-dest ! ip>lan
    3 >r \ four tries before giving up
    BEGIN  dup ip>mac dup 0= WHILE  drop
	    dup l>< req-arp   seconds rx-tail @
	    BEGIN  pause 2dup seconds rx-tail @ d<>  UNTIL  2drop
	    r> 1- dup >r 0< IF  -37 throw  THEN
    REPEAT  rdrop
    r> 6 move drop ;

: udp-socket ( ip port addr -- source-port ) >r
    swap \ ip is in host byte order
    r@ ip-socket
    17 r@ ip-protocol c! \ set protocol to UDP
    0 r@ udp-len !
    r@ udp-dest be-w! \ dest port
    udp-myport# @ dup r> udp-src be-w! \ generate new source port
    1 udp-myport# +! ;

\ -----------------------------------------------
\  ICMP Ping
\ -----------------------------------------------

: ip-reply ( addr destaddr -- addr destaddr' )
    over eth-src over eth-dest 6 move eth-src ffmac,
    $800 tw, over ip-version 10 t$, 0 tw, \ checksum 0
    myip 4 t$, over ip-src 4 t$, ;

\ : >carries ( n -- n' )
\     dup 16 rshift swap $FFFF and + ;
\ : ip-cs ( addr u -- cs )
\     0 -rot bounds ?DO  I be-w@ +  2 +LOOP  >carries >carries
\     $FFFF xor ;

: icmp-rx ( addr len -- )
    over icmp-type c@ 8 = IF
	icmp-header# - 4 - >r TX-Puffer ip-reply
	0 tl, \ type 0, code 0, cs not set
	over icmp-header# + over r@ move \ copy rest
	2drop \ the engine calculates the header for us
	\ dup 4 - r@ 4 + ip-cs swap 2 - over hex. dup hex. cr be-w!
	TX-Puffer r> icmp-header# + tx-buffer+
    ELSE
	singletask
	." ICMP received" cr
	.ippacket
    THEN ;


\ -----------------------------------------------
\  UDP Basics
\ -----------------------------------------------

udp-header# aligned buffer: term-hdr
udp-header# aligned buffer: data-hdr

: udp-reply ( addr destaddr -- addr destaddr' )
    ip-reply
    over udp-dest be-w@ tw, \ swap dest/src
    over udp-src  be-w@ tw,
    0 tl, ; \ length+CS stub

: sendv ( addr u hdr -- ) >r
    dup 8 + r@ udp-len be-w!
    dup 28 + r@ ip-len be-w!
    r> udp-header# 2swap tx-buffer+2 ;

: udp-data ( addr u -- ) \ just setup the reply buffer
    drop data-hdr udp-reply 2drop ;

\ -----------------------------------------------
\  UDP Terminal
\ -----------------------------------------------

' nop variable flush-hook
: term-flush flush-hook @ execute ;

\ inject strings into terminal

: /string ( addr1 u1 n -- addr2 u2 )
    tuck - >r + r> ;

1472 Constant udp-max# \ 1518 maximum for non-VLAN packets

udp-max# buffer: inject-buffer
udp-max# buffer: emit-buffer
0. 2Variable inject-keys
0 Variable emit-chars

: term-type ( addr u -- ) \ unbuffered type
    term-hdr @ IF  term-hdr sendv  ELSE  2drop  THEN ;
: (term-flush) ( -- )
    emit-chars @ IF  emit-buffer emit-chars @ term-type  0 emit-chars !  THEN ;

true variable serial?
true variable flush-key?

: udp-key? ( -- flag ) serial-key? inject-keys @ 0<> or ;
: udp-key ( -- key )
    flush-key? @ IF  term-flush  THEN
    BEGIN
	serial-key? IF  serial-key  EXIT  THEN
	inject-keys 2@ dup IF
	    over c@ >r 1 /string inject-keys 2!
	    r> dup 3 = IF  drop  true flush-key? !
	    ELSE  EXIT  THEN
	ELSE  2drop  THEN
    AGAIN ;

: udp-emit ( char -- ) serial? @ IF  dup serial-emit  THEN
    emit-buffer emit-chars @ + c!
    1 emit-chars +!  emit-chars @ udp-max# u>=  IF  term-flush  THEN ;

: >udp-data ( addr u hdr -- addr' u' )
    >r over r> udp-reply 2drop
    udp-header# - >r
    dup udp-len be-w@ 8 - r> umin >r \ careful: smaller limit wins!
    udp-header# + r> ;

: udp-term ( addr u -- )  term-hdr >udp-data
    >r inject-buffer r@ move
    inject-buffer r> inject-keys 2! ;

: udp-io ( -- )
    ['] udp-emit hook-emit !
    ['] udp-key? hook-key? !
    ['] udp-key hook-key !
    ['] (term-flush) flush-hook ! ;

: include ( "name" -- )  false flush-key? !
    2 emit term-flush 1000 0 DO LOOP \ wait a bit
    token type term-flush ;

: .udphdr ( addr len -- )
    ." UDP src:  " over udp-src  be-w@ . cr
    ." UDP dest: " over udp-dest be-w@ . cr ;
: .udppacket ( addr len -- )  .iphdr .udphdr .packet cr ;

\ -----------------------------------------------
\  DHCP, UDP port 58 (only discover+request)
\ -----------------------------------------------

: chars, ( addr u -- )  bounds ?do  I c@ c,  LOOP ;

$63825363 Constant dhcp-magic \ DHCP magic
mymac 2@ xor Variable dhcp-xid
Create dhcp-head
$45 c, $10 c, $00 c, $00 c,
$00 c, $00 c, $40 c, $00 c,
$40 c, $11 c,
Create dhcp-discover
53 c,  1 c, 1 c, \ message type: discover
\ 61 c,  7 c, mymac 6 chars, 0 c, \ again: my mac
\ 60 c, 13 c, char " parse net2o-ec 1.0" chars, 0 c, \ vendor id
\ 12 c,  9 c, char " parse net2o-ec" chars, 0 c, \ host id
55 c,  6 c, 58 c, 59 c,  1 c, 28 c, 33 c, 3 c, \ parameter request list
$FF c,
here dhcp-discover - Constant dhcp-discover#

: new-dhcp ( -- )
    1 dhcp-xid +! ; \ new "random" ID number

: dhcp-part-1 ( start -- addr u )
    ffmac, ffmac, \ broadcast, my mac wird ersetzt
    $0800 tw, \ IPv4
    dhcp-head 10 t$, 0 tw, \ constant part of header
    0 tl, -1 tl, \ my ip: 0.0.0.0, dest: 255.255.255.255
    68 tw, 67 tw, 0 tw, 0 tw, \ DHCP ports + len + checksum
    $01010600 tl, dhcp-xid @ tl,
    20 tz, \ 20 bytes all zero are ok
    mymac over 6 move 6 + 10 tz, \ 16 bytes for mac
    192 tz, \ no server host name, no boot file
    dhcp-magic tl, ;

: dhcp-discover ( -- ) \ generate a dhcp discover
    TX-Puffer dhcp-part-1
    dhcp-discover dhcp-discover# t$,
    TX-Puffer udp-header# + tuck - TX-Puffer sendv ;

0 Variable dhcp-server-ip

: dhcp-request ( ip -- ) >r \ generate a dhcp request
    TX-Puffer dhcp-part-1
    dhcp-server-ip @ TX-Puffer $3E + !
    r@ l>< TX-Puffer $3A + !
    53 tc, 1 tc, 3 tc, \ message type: request
    50 tc, 4 tc, r> tl,
    51 tc, 4 tc, 24 60 60 * * tl, \ request for a day
    54 tc, 4 tc, dhcp-server-ip be-l@ tl,
    $FF tc,
    TX-Puffer udp-header# + tuck - TX-Puffer sendv ;

-1 variable last-tick
0 Variable lease-time
10 Variable lease-threshold
0 Variable dhcp-type

: next-dhcp ( addr u -- addr' u' )
    over 1+ c@ 2 + /string ;
: dhcp-options ( addr u -- )  -1 dhcp-type !
    BEGIN
	case  over c@
	    51 of  over 2 + be-l@ dup lease-time !
		3 rshift lease-threshold !  endof
	    53 of  over 2 + c@ dhcp-type !  endof
	    54 of  over 2 + @ dhcp-server-ip !  endof
	    3  of  over 2 + @ routing !  endof
	    1  of  over 2 + @ routing cell+ !  endof
	    28 of  over 2 + @ routing cell+ cell+ !  endof
	    $FF of  2drop  EXIT  endof
	endcase
	next-dhcp
    dup 1- 0< UNTIL  2drop ;

: dhcp-offer ( addr u -- ) \ receive the offer
    udp-header# /string
    dup $F0 u<= IF
	." DHCP too short" cr  2drop EXIT  THEN
    over c@ 2 <> IF  2drop EXIT  THEN \ not an offer
    \    over $EC + be-l@ dhcp-magic <>
    \ IF  ." Wrong magic" cr  2drop EXIT  THEN \ not dhcp
    \    over cell+ be-l@ dhcp-xid @ <> IF
    \ ." not our request: " over cell+ be-l@ u. cr
    \ .packet  EXIT  THEN \ not our request
    over $10 + be-l@ >r
    $F0 /string  dhcp-options
    case  dhcp-type @
	2 of  r@ dhcp-request  endof
	5 of  r@ l>< myip !  new-dhcp
	    routing be-l@ req-arp  endof \ ack
	6 of  0 lease-time !  new-dhcp  endof \ nack
    endcase  rdrop ;

: dhcp-tick ( -- )
    last-tick @ seconds dup last-tick ! -
    lease-time +!
    lease-time @ 0< IF  dhcp-discover  EXIT  THEN
    lease-time @ lease-threshold @ < IF
	myip be-l@ dhcp-request
    THEN ;


\ -----------------------------------------------
\  UDP port dispatcher
\ -----------------------------------------------

' .udppacket 0
' .udppacket 0
' .udppacket 0
' .udppacket 0
' .udppacket 0
10 nvariable free-udpports

' dhcp-offer 68
' udp-data 4202
' udp-term 4201
6 nvariable udpports

: udp-rx ( addr u -- )
    over udp-dest be-w@
    \ ." udp packet port: " dup . cr
    udpports 16 cells bounds do
	dup i @ = if
	    drop  i cell+ @ execute  unloop  exit
	then
    2 cells  +loop  drop 2drop ;


\ -----------------------------------------------
\  IP dispatcher
\ -----------------------------------------------

' .ippacket 0
' .ippacket 0
' .ippacket 0
' .ippacket 0
' .ippacket 0
' .ippacket 0
12 nvariable free-iptypes

' udp-rx 17
' icmp-rx 1
4 nvariable iptypes

: rx-ip ( desc -- ) desc@ over ip-protocol c@
    \ ." ip packet type: " dup . cr
    iptypes 16 cells bounds do
	dup i @ = if
	    drop  i cell+ @ execute  unloop  exit
	then
    2 cells  +loop  drop .ippacket ;


\ -----------------------------------------------
\  Ethertype dispatcher
\ -----------------------------------------------

' dump-rx 0
' dump-rx 0
' dump-rx 0
' dump-rx 0
' dump-rx 0
10 nvariable free-ethertypes

' rx-arp  $0806
' rx-ipv6 $86DD
' rx-ip   $0800
6 nvariable ethertypes

: rx-ethertype ( descriptor ethertype -- )
    ethertypes 16 cells bounds do
	dup i @ = if
	    drop  i cell+ @ execute  unloop  exit
	then
    2 cells  +loop  drop dump-rx ;

: handle-rx ( descriptor -- )
    dup 8 + @ eth-type be-w@ rx-ethertype ;	


\ -----------------------------------------------
\  Ethernet handling task
\ -----------------------------------------------

: sys-tick? ( -- )
    seconds last-tick @ <> IF
	dhcp-tick
    THEN ;

: ether-loop ( -- )
    BEGIN
	BEGIN  pause  sys-tick?  RX-Descriptor' @ own and 0=  UNTIL
	
	RX-Descriptor' dup >r handle-rx
	r> 8 + @ ether-size rx-buffer+
	rx-tail+
    AGAIN ;

: ethernet& ( -- )
    ethernet-task activate
    BEGIN  ['] ether-loop catch  drop  AGAIN
;

\ -----------------------------------------------
\  Hardware initialisations for MAC and PHY
\ -----------------------------------------------

$400FE000 constant Sysctl-Base

Sysctl-Base $630 + constant RCGCEPHY
Sysctl-Base $69C + constant RCGCEMAC
Sysctl-Base $0B0 + constant RSCLKCFG
Sysctl-Base $07C + constant MOSCCTL
Sysctl-Base $930 + constant PCEPHY
Sysctl-Base $99C + constant PCEMAC

\ Constants for EMACDMABUSMOD

1 7 lshift constant ATDS

\ Constants for EMACCFG

1 14 lshift constant FES
1 11 lshift constant DUPM
1  3 lshift constant TE
1  2 lshift constant RE

\ Constants for MOSCCTL
1 4 lshift constant OSCRNG

PORTF_BASE $420 + constant PORTF_AFSEL  ( Alternate Function Select )
PORTF_BASE $52C + constant PORTF_PCTL   ( Pin Control )

: clocks-enable ( -- )
    \ Enable MOSC and use this as system clock:

    OSCRNG MOSCCTL ! \ High range for MOSC
    
    \ while we wait for the clock to stabilize...
    50 0 do  loop
    
    3 20 lshift RSCLKCFG ! \ MOSC as oscillator
    
    \ Enable clock for Ethernet:

    1 RCGCEMAC !  1 RCGCEPHY ! ;

: descs-setup ( -- )  0 term-hdr !
    RX-Descriptors desc-size descs# * 0 fill
    TX-Descriptors desc-size txdescs# * 0 fill
    arp-cache /arp arp-cache# *       0 fill

    \ allow eight frames to be received
    rx-puffer-7 rx-puffer-0 do
	i ether-size rx-buffer+
    ether-size negate +loop ;

: enable-emac ( -- )
    1 PCEMAC ! \ Enable EMAC
    1 PCEPHY ! \ Enable EPHY
;

: reset-emac ( -- )
    \ Write to the Ethernet MAC DMA Bus Mode (EMACDMABUSMOD) register to set Host bus parameters.
    
    ." Reset Ethernet" cr
    1 EMACDMABUSMOD ! \ Reset MAC
    begin EMACDMABUSMOD @ 1 and not until \ Wait for Reset to complete
    ." Reset complete" cr
    EMACDMABUSMOD @ ATDS or EMACDMABUSMOD ! ;

: emac-leds ( -- )
  \ Set Ethernet LEDs on Port F:
     $11  PORTF_AFSEL !
  $50005 PORTF_PCTL ! ;

: emac-irqs ( -- )
  56 nvic-enable \ Enable ethernet vector in NVIC

  ['] ethernet-handler irq-ethernet !
  \ Write to the Ethernet MAC DMA Interrupt Mask Register (EMACDMAIM) register to mask unnecessary interrupt causes.

  RIE NIE or EMACDMAIM ! \ Interrupts: Receive and normal interrupt summary
;

: emac-init ( -- )
  mymac cell+ @ EMACADDR0H !
  mymac       @ EMACADDR0L !
  
  \ Create the transmit and receive descriptor lists and then write to the Ethernet MAC Receive
  \ Descriptor List Address (EMACRXDLADDR) register and the Ethernet MAC Transmit
  \ Descriptor List Address (EMACTXDLADDR) register providing the DMA with the starting
  \ address of each list.

  RX-Descriptors EMACRXDLADDR !
  TX-Descriptors EMACTXDLADDR !

  \ Write to the Ethernet MAC Frame Filter (EMACFRAMEFLTR) register, the Ethernet MAC
  \ Hash Table High (EMACHASHTBLH) and the Ethernet MAC Hash Table Low
  \ (EMACHASHTBLL) for desired filtering options.

  0 EMACFRAMEFLTR ! \ no filtering, normal mode

  \ Write to the Ethernet MAC Configuration Register (EMACCFG) to configure the operating
  \ mode and enable the transmit operation.

  3 28 lshift \ saddr=replace with addr0
  FES or  \ 100 Mbps
  DUPM or \ Full Duplex
  TE or   \ Transmitter Enable
  RE or   \ Receiver Enable
  EMACCFG !

  \ Program Bit 15 (PS) and Bit 11 (DM) of the EMACCFG register based on the line status received
  \ or read from the PHY status register after auto-negotiation.

  \ Hardwired to Full-Duplex, store&forward, 100 Mbps here.
  1 21 lshift 1 13 lshift or 2 or EMACDMAOPMODE ! ;


\ -----------------------------------------------
\  Activate everything on startup
\ -----------------------------------------------

: quit-loop ( -- )  BEGIN  term-flush query interpret ."  ok." cr  AGAIN ;
: quit-catch ( -- )  BEGIN  ['] quit-loop catch
        dup IF  ." Throw: " . cr  ELSE  drop  THEN  AGAIN ;

: sysfault ( -- ) -9 throw ;

: init ( -- )
    init  multitask
    ['] quit-catch hook-quit !
    ['] sysfault irq-fault ! ;

init
quit \ Activate Multitasking and new Catch/Throw mechanism


\ D3: Link-OK LED
\ D4: RX/TX   LED

: init ( -- )
    init
    clocks-enable RTC-Init
    descs-setup  enable-emac
    reset-emac  emac-leds  emac-irqs  emac-init
    \ start background task
    ethernet& udp-io
    ." Mecrisp-Stellaris ethernet terminal ready" cr
;

compiletoram
init


