! 2MHz Ether handler for "new" Mouse, RWT Aug 1988,
! adapted from GDMR's version for "interim" Mouse, Dec 1987....

! This handler runs the station in "raw" mode.  It speaks the "standard"
! protocol (type 01/81), providing a port-like interface, and in addition
! allows the use of other protocol-types (for IP, ARP and the like).

%option "-nonstandard-low-nocheck-nodiag-noline"

%include "nmouse.inc"
%include "2meg.inc-list"

{L{ %include "GDMR_H:Lights.Inc"
{L{ %constinteger lights type           = 16_80
{L{ %constinteger lights sending        = 16_40
{L{ %constinteger lights outbound       = 16_20
{L{ %constinteger lights old outbound   = 16_10
{L{ %constinteger lights old reTX       = 16_04 {16_08
{L{ %constinteger lights inbound        = 16_20
{L{ %constinteger lights old inbound    = 16_10
{L{ %constinteger lights clear          = 16_F8

%ownrecord(interrupt handler fm) interrupt handler = 0  {* First %own ! *} 

%constinteger ether packet size = 768-14;  ! Excludes header

%constinteger RX buffers            = 16;  ! 2^n ??
%constinteger reTX lives            = 6
%constinteger old protocol slots    = 48
%constinteger first station         = 16_10
%constinteger last station          = 16_7F
%constinteger last registered       = 16

%constinteger         overall size     = 14000
%constinteger inbound handler size     = 2000
%constinteger timeout handler size     = 2000

! Ether station definitions

@16_7FFFC %readonly %volatile %byte status %or %writeonly %byte command
@16_7FFFD %byte data, *, control

%constinteger DTX = 16_30
%constinteger RDY = 16_10
%constinteger STX = 16_20
%constinteger ETX = 16_0B
%constinteger ACK = 16_C0
%constinteger ESA = 16_05
%constinteger SSA = 16_07
%constinteger RAW = 16_02

%constinteger int bit = 7, int mask = 1 << int bit
%constinteger rst bit = 6, rst mask = 1 << rst bit
%constinteger td  bit = 3, td  mask = 1 << td  bit
%constinteger rd  bit = 2, rd  mask = 1 << rd  bit
%constinteger rc  bit = 1, rc  mask = 1 << rc  bit
%constinteger rcd bit = 0, rcd mask = 1 << rcd bit

%constinteger interrupt level = 4
! SR values:
%constinteger interrupts off  = interrupt level<<8
%constinteger interrupts on   = 0
%constinteger supervisor mode = 16_2000


! Statistics

%owninteger this station            = 0
%owninteger buffer low water        = maxint
%owninteger unrecognised control    = 0
%owninteger inbound packets         = 0
%owninteger inbound bytes           = 0;  ! not counting 14 byte header
%owninteger outbound packets        = 0
%owninteger outbound bytes          = 0;  ! not counting 14 byte header
%owninteger dud destinations        = 0
%owninteger dud types               = 0
%owninteger old inbound packets     = 0;  ! Data packets, not ACKs
%owninteger old outbound packets    = 0;  ! Data packets, not ACKs
%owninteger old inbound no takers   = 0
%owninteger old retransmits         = 0
%owninteger old ACK timeouts        = 0
%owninteger old user timeouts       = 0
%owninteger old defines             = 0
%owninteger old redefines           = 0
%owninteger old undefines           = 0
%owninteger old reads               = 0
%owninteger old writes              = 0
%owninteger pended DTX              = 0
%owninteger packets dropped         = 0
@#this station %record(ether stats fm)stats

%routine disaster(%string(255)which)
%integer i
   i = or to SR(16_700)
   newline
   printstring("2MHz ";which;" handler: unexpected event: ";poa_message)
   write(poa_event, 1; poa_sub, 1);  space;  phex(poa_extra)
   printstring(" near PC ");  phex(poa_event PC)
   newline
   %for i = 0, 1, 15 %cycle
      phex(poa_event regs(i));  space
      newline %if i & 7 = 7
   %repeat
   semaphore wait(nil)
%end

! Buffer pool management

! We use a common format for request messages and ether buffers.
! However, we keep a pool of buffers to be filled by the receive
! interrupt handler.  The process which first fields incoming
! packets either puts them straight back into the receive pool
! (when it doesn't know what else to do with them), or it sends
! them on to the user (if there were pending read requests), in
! which case the read request buffer gets put back into the pool,
! or (when there are no read requests pending, but are likely to
! materialise "soon") the packet is saved in a pending queue. In
! this case the receive pool is replenished by a fresh buffer
! from the system pool.  Correspondingly, when read requests are
! satisfied by pending packets, the packets are sent to the user
! and the requests are returned to the system pool.

%recordformat ether header fm(%byte ds, dp, %integer dz,
                              %byte ss, sp, %integer sz,
                              %byte type, seq)

%constinteger old data type = 16_01
%constinteger old ACK  type = 16_81

%ownrecord(queue fm)RX buffer pool                        = 0
%ownrecord(queue fm)inbound queue                         = 0
%ownrecord(semaphore fm)%name inbound packet arrived     == nil
%owninteger buffers remaining   { for information only }  = 0

%routine to RX pool(%record(ether buffer fm)%name buffer)
   move to SR(interrupts off)
      buffer low water = buffers remaining %if buffers remaining < buffer low water
      buffers remaining = buffers remaining + 1
      enqueue(buffer_system part_header,RX buffer pool)
   move to SR(interrupts on)
%end

%record(ether buffer fm)%map from RX pool
%record(ether buffer fm)%name b
   b == dequeue(RX buffer pool)
   %unless b == nil %start
      b_offset = 1
      buffers remaining = buffers remaining-1
   %finish
   %result == b
%end

%record(ether buffer fm)%map from system pool
%record(*)%name b
   b == get message buffer
   %result == b
%end

%routine to system pool(%record(ether buffer fm)%name buffer)
   put message buffer(buffer_system part)
%end

%routine setup RX buffer pool
%integer i
   to RX pool(from system pool) %for i = 1, 1, RX buffers
   buffers remaining = RX buffers
   buffer low water = RX buffers
%end

%routine complete request(%record(ether buffer fm)%name r,%integer status)
  r_status = status
  send message(r_system part,r_system part_reply)
%end

%routine complete read request(%record(ether buffer fm)%name packet,request)
%record(ether header fm)%name header == record(addr(packet_data(1-14)))
   packet_ra = header_ss;  packet_rp = header_sp
   packet_la = header_ds;  packet_lp = header_dp
   packet_type = header_type
   packet_code = request_code
   packet_tag = request_tag
   packet_context = request_context
   packet_system part_reply == request_system part_reply
   complete request(packet,ether success)
%end

%ownbytename TX buffer == nil
%owninteger TX bytes = 0
%ownrecord(semaphore fm)%name TX done == nil


%routine put data char(%registerinteger x)
  %cycle; %repeatuntil status&td mask#0
  data = x
%end

%routine put control char(%registerinteger x)
  %cycle; %repeatuntil status&td mask#0
  control = x
%end

%routine put control pair(%registerinteger x)
  put control char(x)
  x = 0; put data char(x)
%end

%routine skip data char
  %cycle; %repeatuntil status&rd mask#0
  d0 = data
%end

! Interrupt handler

%routine setup station handler
   %owninteger pending DTX = -1
   %ownrecord(ether buffer fm)%name RX buffer == nil
   %label interrupt

   interrupt handler_pc = addr(interrupt)
   add interrupt handler(interrupt level)
   move to SR(supervisor mode)
      command = rst mask;          ! Ints off, reset the station
      command = 0;                 ! Ints still off, un-reset
      put control char(RAW)
      put control char(ESA)
      command = rc mask ! rd mask; ! Enable receive interrupts
   move to SR(interrupts on)
   %cycle
      %returnunless this station = 0
   %repeat

interrupt:

%register(a1)%bytename b
   *temp d0-d1/a0-a1

! The interupt handler proper.  We enable interrupts for received data
! and control characters (cleared by reading the appropriate register).
! The following may be received:
!     DTX: something has arrived from the wire
!     STX: the packet we asked for is coming up next
!     ETX: our packet has just finished (this won't cause an interrupt
!          as we're in a busy-wait loop at the time reading the packet)
!     RDY: the station is ready for our (TX) packet
!     ACK: can be ignored!
!     SSA: the station address is coming up next.
! Since we're in "raw" mode the "port" part of these will always be zero.
! Note, however, that it will be present and must be explicitly handled.
! If it's anything we don't recognise we log it and ignore it.  We have
! reasonable control over the receipt of everything except DTX, which
! is driven by packets arriving off the wire.  Since we're only geared
! up to handle one receive buffer at a time we tally the "extra" DTXs
! for future processing.
!
! Note: data is transferred in a busy-wait loop in the interrupt handler.
! This should result in less overhead than interrupt-per-character would.
! Any data interrupts are assumed to be caused by the station misbehaving:
! the character is read (to clear the condition) and thrown away.

! First off, read the status register to see if the interrupt was for us.
! If it wasn't we just return; if it was we fetch the control character
! (or read and throw away the data character).

   d0 = status
   return from interrupt %if d0&int mask=0  {station not interrupting =>}
   %if d0&rc mask=0 %start       {not control (i.e. data) char: discard}
     d1 = data
{}   rompstr("2MHz: spurious  "); romphex2(d1); rompsym(nl)
     return from interrupt
   %finish

! Next, read the control character and act upon it.

   d1 = control
   -> DTX arrived %if d1=dtx
   -> STX arrived %if d1=stx
   -> RDY arrived %if d1=rdy
   -> ACK arrived %if d1=ack
   -> SSA arrived %if d1=ssa
{} rompstr("2MHz: spurious ^"); romphex2(d1); rompsym(nl)
   unrecognised control = unrecognised control+1
   return from interrupt

DTX arrived:

! A packet has arrived in the station.
! Claim a buffer, ready to be filled with the packet when
! we ask for it by sending a RDY.
! If no buffer is available, tell the station to throw
! the packet away by sending an ACK.
! When DTX's pile up we simply count them - we only ask for
! one packet at a time.

   skip data char                { throw away port byte
   pending DTX = pending DTX+1   { Bump pending tally
   %if pending DTX#0 %start      { One pending already
      pended DTX = pended DTX+1  { Tally it
      return from interrupt      { Must wait meantime
   %finish
   RX buffer == from RX pool
   %if RX buffer == nil %start   { No buffers left
      put control pair(ACK)
   %else
      put control pair(RDY)
   %finish
   return from interrupt

STX arrived:

! The STX has arrived.  Data frame will be arriving next.
! Read it in and tally it.  When the ETX arrives put the buffer on
! the arrived queue and signal the inbound handler's semaphore.

   skip data char
   b == rx buffer_data(1-14)       { Start of packet header
   D1 = -14                        { Zap tally
   %cycle
      %exitif status&rcmask#0      { Control ->
      %continueif status&rdmask=0  { No data yet
      *move.b data, (B)+           { Read the character
      d1 = d1+1                    { Bump tally
   %repeat                         { Round for the next one
   RX buffer_bytes = d1            { Note packet size
   d0 = control                    { Must have been the ETX??
   enqueue(RX buffer_system part_header,inbound queue) { Link us in
   int signal semaphore(inbound packet arrived)
   pending DTX = pending DTX-1     { Note packet has been done
   %if pending DTX<0 %start        { No more packets waiting in station
      RX buffer == nil
   %else
      RX buffer == from RX pool
      %if RX buffer == nil %start
        packets dropped = packets dropped+1
        put control pair(ACK)      { ask station to throw it away
      %else
        put control pair(RDY)      { ask station to let us have it
      %finish
   %finish
   return from interrupt

RDY arrived:

! This must have been in response to our DTX.  The TX buffer address
! and length will already have been set up, so all we have to do is
! hand it on to the station, bracketed by STX/ETX.  Since we're in raw
! mode the packet must be at least 14 bytes long, so we don't have to
! worry about dealing with awkward empty ones....

   skip data char
   put control pair(STX)
   d0 = TX bytes-1      { Number of bytes to send (adjusted for DBRA)
   b == TX buffer       { First byte to go
txloop:
      %cycle; %repeatuntil status&tdmask#0
      *move.b (B)+, data
   *dbra D0, txloop
   put control char(ETX)
   int signal semaphore(TX done)
   return from interrupt

ACK arrived:

! This is just in to keep the host/station protocol the same for raw
! mode as it is for cooked mode.  We just read the port byte and
! ignore it all....

   skip data char
   return from interrupt

SSA arrived:

! The next data character will be the station address

   %cycle; %repeatuntil status&rdmask#0
   this station = data
   return from interrupt

   *nop {?!}
%end


! Inbound packet handler

%recordformat icb fm(%integer active,
                     %record(queue fm)pending packets, pending reads)

%ownrecord(icb fm)%array icbs(2 : last registered) = 0(*)
%ownrecord(semaphore fm)%name icb semaphore == nil

%routinespec old inbound handler(%record(ether buffer fm)%name buffer)

%routine inbound handler
%record(ether buffer fm)%name buffer
%record(ether header fm)%name header
%record(icb fm)%name icb
%record(ether buffer fm)%name rr
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      ! Last-chance disaster-trap
      disaster("inbound")
   %finish
!! printstring("Inbound handler: ");  write(free store, 0);  newline
   %cycle
      %cycle
{L{      lights and B(\ lights inbound)
         semaphore wait(inbound packet arrived)
{L{      lights or B(lights inbound)
         move to SR(interrupts off)
            buffer == dequeue(inbound queue)
         move to SR(interrupts on)
         %exitif buffer_bytes < 0                 {"runt"} -
             %or buffer_bytes > ether packet size {or outsize packet}
         inbound bytes = inbound bytes + buffer_bytes
         inbound packets = inbound packets + 1
         header == record(addr(buffer_data(buffer_offset-14)))
         %if 0 # header_ds # this station %start
            ! Not for us
            to RX pool(buffer)
            dud destinations = dud destinations + 1
         %else %if header_type = old data type %c
               %or header_type = old ACK type
            ! Hand the buffer to the old protocol handler.  Let it
            ! free the buffer when it's finished
            old inbound handler(buffer)
         %else %if 2 <= header_type <= last registered
            semaphore wait(icb semaphore)
            icb == icbs(header_type)
            %exitif icb_active = 0
            rr == dequeue(icb_pending reads)
            %if rr == nil %start
               ! Nothing waiting, so put it on the end of the list
               ! and replenish the pool with a new buffer
               enqueue(buffer_system part_header,icb_pending packets)
               to RX pool(from system pool)
            %else
               ! There's a read request already waiting, so complete it
               complete read request(buffer, rr)
               to RX pool(rr)
            %finish
            signal semaphore(icb semaphore)
         %finishelseexit
      %repeat
      to RX pool(buffer)
      dud types = dud types + 1
   %repeat
%end


! Outbound packet handler

%ownrecord(semaphore fm)%name outbound semaphore == nil

%routine outbound packet handler(%record(ether header fm)%name header,
                                 %record(ether buffer fm)%name buffer)
{L{lights or A(lights outbound)
   outbound packets = outbound packets + 1
   ! Grab semaphore, set up parameters for the transfer
   semaphore wait(outbound semaphore)
   %if buffer == nil %start  {Header-only transfer (as in ACK)}
      TX buffer == header_ds
      TX bytes = 14
   %else
      TX buffer == buffer_data(buffer_offset-14)
      move(14,header,TX buffer)
      TX bytes = buffer_bytes+14
      outbound bytes = outbound bytes+buffer_bytes
   %finish
   ! Kick the station
{L{lights or A(lights sending)
   move to SR(interrupts off ! supervisor mode)
      put control pair(DTX)
   move to SR(interrupts on)
   semaphore wait(TX done)
{L{lights and A(\lights sending)
   signal semaphore(outbound semaphore)
{L{lights and A(\ lights outbound)
%end


! Old-style protocol handler.

! Protocol control blocks are accessed in one of two ways: from the user side
! they are accessed directly by indexing into the table, while from the ether
! side they are accessed indirectly via a table of chained blocks, one slot 
! for each remote address.  "Port 0" is slightly special-cased to set up the
! destination station and port and to register the existence of a recipient.
! Mostly it is just the same as the VC ports.

%recordformat old protocol fm(%record(old protocol fm)%name next,
                              %record(ether header fm) header,
                              %integer reTX lives, next reTX, reTX interval,
                              %integer last seq, last address,
                              %record(queue fm) pending packets,
                                                pending reads, pending writes)

%ownrecord(old protocol fm)%array opcb(0 : old protocol slots) = 0(*)
%ownrecord(old protocol fm)%namearray opsl(first station - 1 : last station) == nil(*)

%ownrecord(semaphore fm)%name old protocol semaphore == nil

%owninteger timestamp = 0

%record(old protocol fm)%map find inbound opcb(%record(ether header fm)%name h)
%record(old protocol fm)%name p
   %result == nil %unless first station <= h_ss <= last station
   p == opsl(h_ss)
   %while p ## nil %cycle
      ! Do source/destination ports match?  Source address for each
      ! pcb is implied by the list it's on.
      %result == p %if p_header_dp = h_sp %and p_header_sp = h_dp
      p == p_next
   %repeat
   %result == nil
%end

%routine do old write(%record(old protocol fm)%name p, %integer setup)
%record(ether buffer fm)%name r
{L{lights or A(lights old outbound)
   %if setup # 0 %start
      p_reTX lives = reTX lives
      p_reTX interval = 1
      p_next reTX = timestamp + 3
   %finish
   r == p_pending writes_forward
   %if p == opcb(0) %start
      ! Port 0, copy in ds and dp
      p_header_ds = r_ra
      p_header_dp = r_rp
   %finish
   outbound packet handler(p_header,r)
   old outbound packets = old outbound packets + 1
{L{lights and A(\ lights old outbound)
%end

%routine old inbound handler(%record(ether buffer fm)%name buffer)
%ownrecord(ether header fm) ACK = 0
%record(ether buffer fm)%name request pending
%record(ether header fm)%name header
%record(old protocol fm)%name p
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      ! Last-chance disaster-trap
      disaster("old inbound")
   %finish
{L{lights or B(lights old inbound)
   header == record(addr(buffer_data(buffer_offset-14)))
   %if header_ds = 0 %start
      ! Drop broadcasts
      p == opsl(first station - 1)
      -> broadcast
   %finish
   semaphore wait(old protocol semaphore)
   %if header_dp = 0 %then p == opsl(first station - 1) %c
                     %else p == find inbound opcb(header)
   %if p ## nil %start
      ! Connection is known.  Is this inbound data or an ACK for
      ! something we've sent?
      %if header_type = old data type %start
         ! Data packet has arrived
         old inbound packets = old inbound packets + 1
         ! First ACK the packet.
         !ACK = 0
         %unless header_ss = this station %start
            ACK_ss = this station;  ! Filled in by station anyway...
            ACK_sp = header_dp
            ACK_ds = header_ss
            ACK_dp = header_sp
            ACK_type = old ACK type
            ACK_seq = header_seq
            outbound packet handler(ACK, nil)
         %finish
         ! Now if this packet's sequence number is new then we forward
         ! the data to the user or queue the buffer if there isn't
         ! a pending read.
         %if header_seq # p_last seq %c
               %or header_ss # p_last address %start
broadcast:  p_last seq = header_seq
            p_last address = header_ss
            request pending == dequeue(p_pending reads)
            %if request pending == nil %start
               ! No user-request waiting, so put this on the pending queue
               ! and replenish the pool.
               enqueue(buffer_system part_header,p_pending packets)
               to RX pool(from system pool)
            %else
               ! There's a user request waiting, so complete it,
               ! and then grab a new buffer to return to the pool.
               complete read request(buffer, request pending)
               to RX pool(request pending)
            %finish
            signal semaphore(old protocol semaphore)
{L{         lights and B(\ lights old inbound)
            %return
         %finish
      %else %if header_type = old ACK type
         ! ACK packet has arrived
         %if header_seq = p_header_seq %c
               %and header_ss = p_header_ds %start
            ! It's an ACK for the last thing we sent.  First bump our
            ! send sequence number (avoiding 0, as cooked stations
            ! treat it as special).
            p_header_seq = (p_header_seq + 1) & 255
            p_header_seq = 1 %if p_header_seq = 0
            ! Now complete the first request on the pending write
            ! queue.
            request pending == dequeue(p_pending writes)
            %if request pending ## nil %start
               complete request(request pending,ether success)
               %unless queue empty(p_pending writes) %start;  ! Kick next
                  do old write(p, 1)
               %finish
            %finish {else spurious ack}
         %finish {else unexpected ack}
      %finish {else something bogus on queue}
   %else
      ! Else ignore it
      old inbound no takers = old inbound no takers + 1
   %finish
   signal semaphore(old protocol semaphore)
   to RX pool(buffer)
{L{lights and B(\ lights old inbound)
%end
         
%routine old ether request(%record(ether buffer fm)%name m)
%record(old protocol fm)%name p, q
%record(ether buffer fm)%name pw
%record(ether buffer fm)%name RX buffer
%integer i, j

   %routine unlink pcb
      i = p_header_ds
      %if first station <= i <= last station %start
         %if opsl(i) == p %start
            ! We're the first on the chain
            opsl(i) == p_next
         %else
            ! We're not first in the chain, so follow it down...
            q == opsl(i)
            q == q_next %while q_next ## nil %and q_next ## p
            %if q == nil %start
               printstring("Slow PCB ");  write(m_context, 0)
               printstring(" not in chain for ");  phex2(i)
               newline
            %else
               q_next == p_next
            %finish
         %finish
      %elseunless i=0
         printstring("Dud ether address ");  phex2(i)
         printstring(" in slow PCB ");  write(m_context, 0)
         newline
      %finish
   %end

   %routine clobber pcb
      ! First off, get rid of any pending RX buffers.
      %cycle
         RX buffer == dequeue(p_pending packets)
         %exitif RX buffer == nil
         to system pool(RX buffer)
      %repeat
      ! Pending read and write requests next...  Complete these
      ! in the order in which they were queued, in case it matters
      ! to the caller.
      %cycle
         pw == dequeue(p_pending reads)
         %exitif pw == nil
         complete request(pw,ether operation aborted)
      %repeat
      %cycle
         pw == dequeue(p_pending writes)
         %exitif pw == nil
         complete request(pw,ether operation aborted)
      %repeat
   %end

   %if m_code = ether old define %start
      old defines = old defines + 1
      %if m_ra < first station -
      %or m_ra > last station  -
      %or m_ra = this station %start
         complete request(m,ether dud destination)
      %else
        semaphore wait(old protocol semaphore)
         m_context = 0
         %for i = 1, 1, old protocol slots %cycle
            p == opcb(i)
            m_context = i %and %exit %if p_header_type = 0
         %repeat
         %if m_context # 0 %start
            ! A free slot.  Link it in.
            p = 0
            p_next == opsl(m_ra) %and opsl(m_ra) == p
            ! Find the lowest free local port
            j = 0
            q == p_next
            %while q ## nil %cycle
               j = j ! (1 << q_header_sp)
               q == q_next
            %repeat
            %for i = 1, 1, 31 %cycle
               %if j & (1 << i) = 0 %start
                  ! Found one free
                  p_header_sp = i
                  m_lp = i
                  %exit
               %finish
               ! Assume for now that this will always succeed!
            %repeat
            p_header_ss = this station
            p_header_ds = m_ra
            p_header_dp = m_rp
            p_header_type = old data type
            p_header_seq = (system elapsed time // 10)&255
            p_last seq = -1
            complete request(m,ether success)
         %else
            ! Must have been last slot, and in use.
            complete request(m,ether no free slots)
         %finish
         signal semaphore(old protocol semaphore)
      %finish
   %else %if m_code = ether old redefine
      old redefines = old redefines + 1
      %if m_ra < first station -
      %or m_ra > last station  -
      %or m_ra = this station %start
         complete request(m,ether dud destination)
      %elseunless 0 < m_context <= old protocol slots
         complete request(m,ether dud context)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            ! Not in use
            complete request(m,ether dud context)
         %else
            ! Change the port number of our peer.  Remember to reset
            ! our send and receive sequence numbers.
            semaphore wait(old protocol semaphore)
            clobber pcb
            p_header_dp = m_rp
            p_header_seq = (system elapsed time // 10)&255 
            p_last seq = -1
            ! Change the station number too.
            %if p_header_ds#m_ra %start
               unlink pcb
               p_header_ds = m_ra
               p_next == opsl(m_ra) %and opsl(m_ra) == p
            %finish
            complete request(m,ether success)
            signal semaphore(old protocol semaphore)
         %finish
      %finish
   %else %if m_code = ether old undefine
      old undefines = old undefines + 1
      %unless 0 < m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            ! Not in use
            complete request(m,ether dud context)
         %else
            ! Clear down this slot.  We have to release any pending receive
            ! buffers and return any pending user requests with an error
            ! status.  Finally, we have to unlink the pcb from the chain
            ! of per-station blocks.
            semaphore wait(old protocol semaphore)
            clobber pcb
            ! Finally, unlink us from the per-station chain
            unlink pcb
            ! Finally, clear it down just to be sure
            p = 0
            complete request(m,ether success)
            signal semaphore(old protocol semaphore)
         %finish
      %finish
   %else %if m_code = ether old read
      old reads = old reads + 1
      m_timeout = m_timeout + timestamp %if m_timeout > 0
      %unless 0 <= m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            ! Undefined
            complete request(m,ether dud context)
         %else
            ! There are two possible cases here: either there is a
            ! packet waiting for someone to read it, or there are
            ! no packets waiting and instead a queue of (zero or more)
            ! read requests waiting.
            semaphore wait(old protocol semaphore)
            RX buffer == dequeue(p_pending packets)
            %if RX buffer == nil %start
               ! No pending packets.  Enqueue our read on the end of
               ! the wait queue.
               enqueue(m_system part_header,p_pending reads)
            %else
               ! A packet awaits a reader.  By implication, there
               ! will be no read requests pending.....
               complete read request(RX buffer, m)
               to system pool(m)
            %finish
            signal semaphore(old protocol semaphore)
            %return
         %finish
      %finish
   %else %if m_code = ether old write
      old writes = old writes + 1
      %unless 0 <= m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else %unless 0 < m_bytes <= ether packet size
         complete request(m,ether operation undefined)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            ! Undefined
            complete request(m,ether dud context)
         %else
            semaphore wait(old protocol semaphore)
            %if queue empty(p_pending writes) %start
               enqueue(m_system part_header,p_pending writes)
               do old write(p, 1)
            %else
               ! Something already going, so just enqueue this one
               enqueue(m_system part_header,p_pending writes)
            %finish
            signal semaphore(old protocol semaphore)
            ! Inbound process will complete it...
         %finish
      %finish
   %else %if m_code = ether old register0
      old defines = old defines + 1
      %if opsl(first station - 1) == nil %start
         ! Not yet defined
         semaphore wait(old protocol semaphore)
         p == opcb(0)
         p = 0
         p_header_ss = this station
         p_header_type = old data type
         p_header_seq = (system elapsed time // 10)&255
         p_header_seq = 1 %if p_header_seq = 0;  ! Avoid 0!!
         p_last seq = -1
         ! ds & dp filled in on per-TX basis
         opsl(first station - 1) == p
         signal semaphore(old protocol semaphore)
         complete request(m,ether success)
      %else
         ! Already registered
         complete request(m,ether operation undefined)
      %finish
   %else %if m_code = ether old unregister0
      old undefines = old undefines + 1
      semaphore wait(old protocol semaphore)
      %if opsl(first station - 1) == nil %start
         ! Undefined
         complete request(m,ether operation undefined)
      %else
         opsl(first station - 1) == nil
         p == opcb(0)
         clobber pcb
         p = 0
         complete request(m,ether success)
      %finish
      signal semaphore(old protocol semaphore)
   %else
      complete request(m,ether operation undefined)
   %finish
%end

%routine timeout handler
%ownrecord(semaphore fm)%name clock semaphore
%record(old protocol fm)%name p
%record(ether buffer fm)%name r, head
%integer i
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      ! Last-chance disaster-trap
      disaster("timeout")
   %finish
   clock semaphore == create semaphore("",0)
   submit regular timer request(clock semaphore,0,100)
!! printstring("Timeout handler: ");  write(free store, 0);  newline
   %cycle
      semaphore wait(clock semaphore)
      timestamp = timestamp+1
      semaphore wait(clock semaphore)
      timestamp = timestamp+1
      !%continue %unless timestamp & 15 = 0
      ! Each time we are wakened we scan the pcb table looking for
      ! user timeouts and retransmit timeouts expiring.
      semaphore wait(old protocol semaphore)
!!    %for i = first station - 1, 1, last station %cycle
!!       p == opsl(i)
      %for i = 0, 1, old protocol slots %cycle
         p == opcb(i)
!!       %while p ## nil %cycle
            %if P_header_type # 0 %start
               ! In use.  First retransmit any pending write requests.
               %if (%not queue empty(p_pending writes)) %c
                     %and p_next reTX <= timestamp %start
                  ! First pending write's timeout has expired.
                  p_reTX lives = p_reTX lives - 1
                  %if p_reTX lives <= 0 %start
                     ! Not ACKed, return an error to user.
                     old ACK timeouts = old ACK timeouts + 1
                     r == dequeue(p_pending writes);  ! Unlink it
                     complete request(r,ether write timeout)
                     ! Transmit the next on the queue, if any
                     ! for all the good it'll do...
                     do old write(p, 1) %unless queue empty(p_pending writes)
                  %else
                     old retransmits = old retransmits + 1
                     p_reTX interval = p_reTX interval << 1
                     p_next reTX = timestamp + p_reTX interval
{L{             !    lights or A(lights old reTX)
                     do old write(p, 0)
{L{             !    lights and A(\ lights old reTX)
                  %finish
               %finish
               ! Now check for expired read timeouts.
               ! Cycle through the whole list taking each request off
               ! the front and putting it back on the end unless we
               ! send it back to the user.
               head == nil;   !remember which request was at the front
               %cycle
                  r == dequeue(p_pending reads)
                  %exitif r == head  {back round to front (or empty)}
                  head == r %if head == nil  {establish front}
                  %if 0 < r_timeout <= timestamp %start
                     ! This one's specified timeout has expired.
                     ! Send back an error message
                     old user timeouts = old user timeouts + 1
                     head == nil %if head == r  {if this was front, zap}
                     complete request(r,ether read timeout)
                  %else
                     ! No timeout specified, or not expired yet.
                     enqueue(r_system part_header,p_pending reads)
                  %finish
               %repeat
               %unless r == nil %start  {put front back on front}
                  requeue(r_system part_header,p_pending reads)
               %finish
            %finish
!!          p == p_next
!!       %repeat
      %repeat
      opcb(0)_last seq = -1 %if timestamp & 63 = 0;  ! Nasty frig for cooked stations
      signal semaphore(old protocol semaphore)
   %repeat
%end


! General protocol handler

%routine ether request(%record(ether buffer fm)%name m)
%record(ether buffer fm)%name RX
%record(ether buffer fm)%name r
%record(icb fm)%name icb
%record(ether header fm) header
   %unless 2 <= m_type <= last registered %start
      complete request(m,ether dud context)
   %finish
   icb == icbs(m_type)
   semaphore wait(icb semaphore)
   %if m_code = ether read %start
      %if icb_active = 0 %start
         signal semaphore(icb semaphore)
         complete request(m,ether dud context)
         %return
      %finish
      RX == dequeue(icb_pending packets)
      %if RX == nil %start
         ! Nothing waiting, we'll have to queue
         enqueue(m_system part_header,icb_pending reads)
         signal semaphore(icb semaphore)
      %else
         ! Take the first pending packet
         signal semaphore(icb semaphore)
         complete read request(RX, m)
         to system pool(m)
      %finish
   %else %if m_code = ether write
      %unless 0 < m_bytes <= ether packet size %start
         signal semaphore(icb semaphore)
         complete request(m,ether operation undefined)
         %return
      %finish
      %if icb_active = 0 %start
         signal semaphore(icb semaphore)
         complete request(m,ether dud context)
         %return
      %finish
      signal semaphore(icb semaphore)
      header_ds = m_ra
      header_dp = 255
      header_dz = 0
      header_ss = this station
      header_sp = 255
      header_sz = 0
      header_type = m_type
      header_seq = 255
      %if m_ra = this station %start  {Loopback}
         move(14,header,m_data(m_offset-14))
         move to SR(interrupts off)
            r == from RX pool
         move to SR(interrupts on)
         complete request(m,ether success) %if r == nil
         r_code = m_code
         r_tag = m_tag
         r_context = m_context
         r_system part_reply == m_system part_reply
         move to SR(interrupts off)
            enqueue(m_system part_header,inbound queue)
         move to SR(interrupts on)
         signal semaphore(inbound packet arrived)
         complete request(r,ether success)
      %else
         outbound packet handler(header, m)
         complete request(m,ether success)
      %finish
   %else %if m_code = ether register
      %if icb_active # 0 %start
         signal semaphore(icb semaphore)
         complete request(m,ether dud context)
         %return
      %finish
      icb_active = 1
      signal semaphore(icb semaphore)
      complete request(m,ether success)
   %else %if m_code = ether unregister
      %if icb_active = 0 %start
         signal semaphore(icb semaphore)
         complete request(m,ether dud context)
         %return
      %finish
      ! Release all pending packets
      %cycle
         RX == dequeue(icb_pending packets)
         %exitif RX == nil
         to RX pool(RX)
      %repeat
      ! Return any pending read requests in the order they were queued
      %cycle
         r == dequeue(icb_pending reads)
         %exitif r == nil
         complete request(r,ether operation aborted)
      %repeat
      ! Mark inactive and release the icb
      icb_active = 0
      signal semaphore(icb semaphore)
      ! Finally send the request back with a success code
      complete request(m,ether success)
   %else
      signal semaphore(icb semaphore)
      complete request(m,ether operation undefined)
   %finish
%end

! Main program -- fields user requests

%begin
%record(process fm)%name p
%record(mailbox fm)%name mailbox == nil
%record(ether buffer fm)%name m
%label start inbound handler, start timeout handler
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      ! Last-chance disaster-trap
      disaster("request")
   %finish
   mailbox                == create mailbox(ether mailbox name,
                             create semaphore("",0))
   become process(overall size)
   inbound packet arrived == create semaphore("",0)
   TX done                == create semaphore("",0)
   icb semaphore          == create semaphore("",1)
   old protocol semaphore == create semaphore("",1)
   outbound semaphore     == create semaphore("",1)
   setup RX buffer pool
   setup station handler
   p == create subprocess(inbound handler size, addr(start inbound handler))
   p == create subprocess(timeout handler size, addr(start timeout handler))
!! printstring("2MHz ether address: "); phex2(this station); newline
!! printstring("2MHz ether handler:"); write(free store,1); newline
{L{lights and B(\ lights clear)
{L{lights and A(\ lights clear)
   %cycle
      m == record(addr(receive message(mailbox)))
      %if m_code & ether old operation # 0 %start
{L{      lights or B(lights type)
         old ether request(m)
{L{      lights and B(\ lights type)
      %else %if m_code & ether operation # 0
{L{      lights or A(lights type)
         ether request(m)
{L{      lights and A(\ lights type)
      %else %if m_code = ether stats
         move(sizeof(stats),stats,m_data(1))
         complete request(m,ether success)
      %else %if m_code = ether station address
         m_context = this station
         complete request(m,ether success)
      %else
         complete request(m,ether operation undefined)
      %finish
   %repeat

start inbound handler:  inbound handler
start timeout handler:  timeout handler

%end %of %program
