Return to net2o.fs CVS log

Up to [gforth] / gforth

Some bugs in the amd64 assembler fixed plus X:xchar feature set query added

    1: \ Internet 2.0 experiments
    2: 
    3: require unix/socket.fs
    4: require string.fs
    5: 
    6: \ Create udp socket
    7: 
    8: 4242 Constant net2o-udp
    9: 
   10: 0 Value net2o-sock
   11: 0 Value net2o-srv
   12: 
   13: : new-server ( -- )
   14:     net2o-udp create-udp-server s" w+" c-string fdopen to net2o-srv ;
   15: 
   16: : new-client ( hostaddr u -- )
   17:     net2o-udp open-udp-socket to net2o-sock ;
   18: 
   19: $81A Constant maxpacket
   20: 
   21: Create inbuf maxpacket allot
   22: 
   23: 2 8 2Constant address%
   24: 
   25: struct
   26:     short% field flags
   27:     address% field dest
   28:     address% field addr
   29:     address% field junk
   30: end-struct net2o-header
   31: 
   32: : read-a-packet ( -- addr u )
   33:     net2o-srv inbuf maxpacket read-socket-from ;
   34: 
   35: : send-a-packet ( addr u -- n )
   36:     net2o-sock fileno -rot 0 sockaddr-tmp 16 sendto ;
   37: 
   38: \ clients routing table
   39: 
   40: 8 Value route-bits
   41: 8 Constant /address
   42: ' dfloats Alias addresses
   43: 0 Value routes
   44: 
   45: : init-route ( -- )
   46:     routes IF  routes free  0 to routes  throw  THEN
   47:     /address route-bits lshift dup allocate throw to routes
   48:     routes swap erase ;
   49: 
   50: : route-hash ( addr -- hash )
   51:     /address route-bits (hashkey1) ;
   52: 
   53: : insert-address ( -- )
   54:     sockaddr-tmp route-hash addresses routes + /address move ;
   55: \ FIXME: doesn't check for collissons
   56: 
   57: : address>route ( -- n/-1 )
   58:     sockaddr-tmp route-hash dup addresses routes + /address tuck
   59:     str= 0= IF  drop -1  THEN ;
   60: : route>address ( n -- )
   61:     addresses routes + sockaddr-tmp /address move ;
   62: 
   63: \ bit reversing
   64: 
   65: : bitreverse8 ( u1 -- u2 )
   66:     0 8 0 DO  2* over 1 and + swap 2/ swap  LOOP  nip ;
   67: 
   68: Create reverse-table $100 0 [DO] [I] bitreverse8 c, [LOOP]
   69: 
   70: : reverse8 ( c1 -- c2 ) reverse-table + c@ ;
   71: : reversex ( x1 -- x2 )
   72:     0 8 0 DO  8 lshift over $FF and reverse8 or
   73: 	swap 8 rshift swap  LOOP ;
   74: 
   75: \ route a packet
   76: 
   77: : packet-route ( -- flag )
   78:     inbuf dest c@ 0= IF  true  EXIT  THEN \ local packet
   79:     address>route reverse8  inbuf dest c@ route>address
   80:     inbuf dest dup 1+ swap /address 1- move
   81:     inbuf dest /address 1- + c!  false ;
   82: 
   83: \ packet&header size
   84: 
   85: $80 Constant destsize#
   86: $40 Constant addrsize#
   87: $20 Constant junksize#
   88: $06 Constant datasize#
   89: 
   90: : header-size ( x -- u ) >r 2
   91:     r@ destsize# and IF  8  ELSE  2  THEN +
   92:     r@ addrsize# and IF  8  ELSE  2  THEN +
   93:     r@ junksize# and IF  8  ELSE  0  THEN +
   94:     rdrop ;
   95: 
   96: Create header-sizes  $100 0 [DO] [I] header-size c, $20 [+LOOP]
   97: 
   98: : packet-size ( -- n )
   99:     inbuf c@ 5 rshift header-sizes + c@
  100:     $20 inbuf c@ datasize# and lshift + ;
  101: : packet-body ( -- addr )
  102:     inbuf dup c@ 5 rshift header-sizes + c@ + ;
  103: 
  104: \ packet delivery table
  105: 
  106: \ each source has multiple destination spaces
  107: 
  108: 0 Value delivery-table
  109: Variable return-addr
  110: Variable dest-addr
  111: 8 Value delivery-bits
  112: 
  113: : init-delivery-table ( -- )
  114:     delivery-table IF  delivery-table free  0 to delivery-table  throw  THEN
  115:     1 cells delivery-bits lshift dup allocate throw to delivery-table
  116:     delivery-table swap erase ;
  117: 
  118: : >ret-addr ( -- )
  119:     inbuf dest @ reversex return-addr ! ;
  120: : >dest-addr ( -- )
  121:     0 inbuf addr 8 bounds ?DO  8 lshift I c@ or  LOOP ;
  122: 
  123: : ret-hash ( -- n )  return-addr 1 cells delivery-bits (hashkey1) ;
  124: 
  125: : check-dest ( -- addr t / f )
  126:     ret-hash cells delivery-table +
  127:     dup @ 0= IF  drop false  EXIT  THEN
  128:     $@ bounds ?DO
  129: 	I 2@ 1- bounds dest-addr @ within
  130: 	0= IF  I cell+ 2@ dest-addr @ swap - + true UNLOOP  EXIT  THEN
  131:     3 cells +LOOP
  132:     false ;
  133: 
  134: Create dest-mapping  0 , 0 , 0 ,
  135: 
  136: : map-dest ( addr u addr' -- )
  137:     ret-hash cells delivery-table + >r
  138:     r@ @ 0= IF  s" " r@ $!  THEN
  139:     dest-mapping 2 cells + ! dest-mapping 2!
  140:     dest-mapping 3 cells r> $+! ;