net2o-cmd.fs 31.8 KB
Newer Older
1 2
\ generic net2o command interpreter

bernd's avatar
bernd committed
3
\ Copyright (C) 2011-2014   Bernd Paysan
bernd's avatar
bernd committed
4 5 6 7 8 9 10 11 12 13 14 15 16 17

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

18
\ net2o commands are protobuf coded, not byte coded.
bernd's avatar
bernd committed
19

20
\ command helper
bernd's avatar
bernd committed
21

bernd's avatar
bernd committed
22
User buf-state cell uallot drop
23

bernd's avatar
bernd committed
24
[IFDEF] 64bit
bernd's avatar
bernd committed
25
    : zz>n ( zigzag -- n )
bernd's avatar
bernd committed
26
	dup 1 rshift swap 1 and negate xor ;
bernd's avatar
bernd committed
27 28
    : n>zz ( n -- zigzag )
	dup 0< swap 2* xor ;
bernd's avatar
bernd committed
29
[ELSE]
bernd's avatar
bernd committed
30
    : zz>n ( 64u -- 64n )
bernd's avatar
bernd committed
31
	64dup 1 64rshift 64swap 64>n 1 and negate n>64 64xor ;
bernd's avatar
bernd committed
32 33
    : n>zz ( 64n -- 64u )
	64dup 64-0< >r 64dup 64+ r> n>64 64xor ;
bernd's avatar
bernd committed
34 35 36
[THEN]
    
: ps!+ ( 64n addr -- addr' )
bernd's avatar
bernd committed
37
    >r n>zz r> p!+ ;
bernd's avatar
bernd committed
38
: ps@+ ( addr -- 64n addr' )
bernd's avatar
bernd committed
39
    p@+ >r zz>n r> ;
40

bernd's avatar
bernd committed
41
: p@ ( -- 64u ) buf-state 2@ over + >r p@+ r> over - buf-state 2! ;
bernd's avatar
bernd committed
42
: ps@ ( -- 64n ) p@ zz>n ;
43 44 45

: byte@ ( addr u -- addr' u' b )
    >r count r> 1- swap ;
bernd's avatar
bernd committed
46

bernd's avatar
bernd committed
47 48 49
\ use a string stack to make sure that strings can only originate from
\ a string inside the command we are just executing

50 51
: @+ ( addr -- n addr' )  dup @ swap cell+ ;

bernd's avatar
bernd committed
52 53
4 2* cells Constant string-max#
User string-stack  string-max# uallot drop
54

bernd's avatar
bernd committed
55
: >$ ( addr u -- $:string )
56 57 58
    string-stack @+ + 2!
    2 cells string-stack +!
    string-stack @ string-max# u>=  !!string-full!! ;
bernd's avatar
bernd committed
59
: $> ( $:string -- addr u )
60 61 62 63
    string-stack @ 0<= !!string-empty!!
    -2 cells string-stack +!
    string-stack @+ + 2@ ;

64 65
: @>$ ( addr u -- $:string addr' u' )
    bounds p@+ [IFUNDEF] 64bit nip [THEN]
bernd's avatar
bernd committed
66
    swap $200000 umin bounds ( endbuf endstring startstring )
bernd's avatar
bernd committed
67
    >r over umin dup r> over umin tuck - >$ tuck - ;
68 69 70

: string@ ( -- $:string )
    buf-state 2@ @>$ buf-state 2! ;
71

72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
\ string debugging

: printable? ( addr u -- flag )
    true -rot bounds ?DO  I c@ $7F and bl < IF  drop false  LEAVE  THEN  LOOP ;

: n2o:$. ( addr u -- )
    2dup printable? IF
	.\" \"" type
    ELSE
	.\" 85\" " 85type
    THEN  '"' emit ;
: n2o.string ( $:string -- )  cr $> n2o:$. ."  $, " ;

: $.s ( $string1 .. $stringn -- )
    string-stack @+ swap bounds U+DO
	cr i 2@ n2o:$.
    2 cells +LOOP ;

90 91 92 93 94 95
\ object stack

8 cells Constant object-max#

User object-stack object-max# uallot drop

96 97 98 99 100 101
: o-pop ( o:o1 o:x -- o1 o:x )
    object-stack @ 0<= !!object-empty!!
    -1 cells object-stack +!
    object-stack @+ + @ ;
: o-push ( o1 o:x -- o:o1 o:x )
    object-stack @+ + !
102 103
    cell object-stack +!
    object-stack @ object-max# u>= !!object-full!! ;
104 105 106

: n:>o ( o1 o:o2 -- o:o2 o:o1 )
    >o r> o-push ;
107
: n:o> ( o:o2 o:o1 -- o:o2 )
108 109 110 111
    o-pop >r o> ;
: n:oswap ( o:o1 o:o2 -- o:o2 o:o1 )
    o-pop >o r> o-push ;

112 113 114 115 116 117 118 119 120 121
\ token stack - only for decompiling

User t-stack

: t-push ( addr -- )
    t-stack $[]# t-stack $[] ! ;
: t-pop ( -- addr )
    t-stack $[]# 1- dup 0< !!object-empty!!
    t-stack $[] @ t-stack $@len cell- t-stack $!len ;

122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
\ float are stored big endian.

: pf@+ ( addr u -- addr' u' r )
    2>r 64 64#0 2r> bounds ?DO
	7 64lshift I c@ $7F and n>64 64+ 64>r 7 - 64r>
	I c@ $80 and  0= IF
	    n64-swap 64lshift
	    0e { f^ pftmp } pftmp 64! pftmp f@
	    I 1+ I' over - unloop  EXIT  THEN
    LOOP   true !!floatfit!!  ;

: pf!+ ( addr r -- addr' ) { f^ pftmp }
    BEGIN
	pftmp 64@ 57 64rshift 64>n
	pftmp 64@ 7 64lshift 64dup pftmp 64!
	64-0<> WHILE  $80 or over c! 1+  REPEAT
    over c! 1+ ;

: pf@ ( -- r )
    buf-state 2@ pf@+ buf-state 2! ;
142

143 144 145 146 147
\ Command streams contain both commands and data
\ the dispatcher is a byte-wise dispatcher, though
\ commands come in junks of 8 bytes
\ Commands are zero-terminated

bernd's avatar
bernd committed
148
: net2o-crash true !!function!! ;
Bernd Paysan's avatar
Bernd Paysan committed
149

150 151
Defer gen-table
' cmd-table IS gen-table
bernd's avatar
bernd committed
152

bernd's avatar
bernd committed
153 154 155 156 157
: $freeze ( addr -- )
    \G copy string to dictionary
    >r r@ $@  align here r> !
    dup , here swap dup allot move align ;

158
: n>cmd ( n -- addr ) cells >r
bernd's avatar
bernd committed
159 160
    o IF  token-table  ELSE  setup-table  THEN
    $@ r@ u<= !!function!! r> + ;
Bernd Paysan's avatar
Bernd Paysan committed
161

bernd's avatar
bernd committed
162
: cmd@ ( -- u ) buf-state 2@ over + >r p@+ r> over - buf-state 2! 64>n ;
163

164 165 166
-5 cells 0 +field net2o.name
drop

bernd's avatar
bernd committed
167
: >net2o-name ( addr -- addr' u )
168
    net2o.name body> name>string ;
bernd's avatar
bernd committed
169

bernd's avatar
bernd committed
170
: (net2o-see) ( addr -- )  @
bernd's avatar
bernd committed
171
    dup 0<> IF
172
	net2o.name
173
	dup 2 cells + @ ?dup-IF  @ token-table @ t-push token-table !  THEN
bernd's avatar
bernd committed
174 175
	body>
    ELSE  drop ['] net2o-crash  THEN  .name ;
176

177
: .net2o-num ( off -- )  cell/ '<' emit 0 .r '>' emit space ;
178 179 180
: .net2o-name ( n -- )  cells >r
    o IF  token-table  ELSE  setup-table  THEN $@ r@ u<=
    IF  drop r> .net2o-num  EXIT  THEN  r> + (net2o-see) ;
bernd's avatar
bernd committed
181 182 183 184
: .net2o-name' ( n -- )  cells >r
    o IF  token-table  ELSE  setup-table  THEN $@ r@ u<=
    IF  drop r> .net2o-num  EXIT  THEN  r> + @
    dup 0<> IF
185
	net2o.name body>
bernd's avatar
bernd committed
186
    ELSE  drop ['] net2o-crash  THEN  .name ;
bernd's avatar
bernd committed
187

188
: net2o-see ( cmd -- ) hex[
189 190
    case
	0 of  ." end-code" cr 0. buf-state 2!  endof
bernd's avatar
bernd committed
191
	1 of  p@ 64. ." lit, "  endof
bernd's avatar
bernd committed
192
	2 of  ps@ s64. ." slit, " endof
bernd's avatar
bernd committed
193
	3 of  string@  n2o.string  endof
194 195 196
	4 of  pf@ f. ." float, " endof
	5 of  ." endwith " cr  t-pop  token-table !  endof
	6 of  ." oswap " cr token-table @ t-pop token-table ! t-push  endof
bernd's avatar
bernd committed
197
	.net2o-name
198
	0 endcase ]hex ;
199

bernd's avatar
bernd committed
200 201
Variable show-offset  show-offset on

202
: cmd-see ( addr u -- addr' u' )
bernd's avatar
bernd committed
203
    dup show-offset @ = IF  ." <<< "  THEN
bernd's avatar
bernd committed
204
    buf-state 2! p@ 64>n net2o-see buf-state 2@ ;
205

206
: n2o:see ( addr u -- ) ." net2o-code "  t-stack $off
bernd's avatar
bernd committed
207
    o IF  token-table @ >r  THEN
208 209
    [: BEGIN  cmd-see dup 0= UNTIL ;] catch
    o IF  r> token-table !  THEN  throw  2drop ;
210

211
: cmd-dispatch ( addr u -- addr' u' )
bernd's avatar
bernd committed
212
    buf-state 2!
bernd's avatar
bernd committed
213
    cmd@ trace( dup IF dup .net2o-name' THEN >r .s r> $.s cr ) n>cmd
bernd's avatar
bernd committed
214 215
    @ ?dup-IF  execute  ELSE
	trace( ." crashing" cr cr ) net2o-crash  THEN  buf-state 2@ ;
bernd's avatar
bernd committed
216

217
: >cmd ( xt u -- ) gen-table $[] ! ;
bernd@vimes's avatar
bernd@vimes committed
218

219 220
Defer >throw

bernd@vimes's avatar
bernd@vimes committed
221 222
\ commands

223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
User cmd0source
User cmdbuf#

: cmdbuf     ( -- addr )  cmd0source @ dup 0= IF
	drop connection .code-dest  THEN ;
: cmdlock    ( -- addr )  cmd0source @ IF  cmd0lock  ELSE
	connection .code-lock THEN ;
: cmdbuf$ ( -- addr u )   cmdbuf cmdbuf# @ ;
: endcmdbuf  ( -- addr' ) cmdbuf maxdata + ;
: maxstring ( -- n )  endcmdbuf cmdbuf$ + - ;
: cmdbuf+ ( n -- )
    dup maxstring u>= !!stringfit!! cmdbuf# +! ;

: cmd, ( 64n -- )  cmdbuf$ + dup >r p!+ r> - cmdbuf+ ;
: flit, ( 64n -- )  cmdbuf$ + dup >r pf!+ r> - cmdbuf+ ;

: net2o, @ n>64 cmd, ;
240

bernd's avatar
bernd committed
241 242
0 Value last-2o

243
: net2o-does  DOES> net2o, ;
bernd@vimes's avatar
bernd@vimes committed
244 245
: net2o: ( number "name" -- )
    ['] noop over >cmd \ allocate space in table
bernd's avatar
bernd committed
246 247
    Create  here to last-2o
    dup >r , here >r 0 , 0 , net2o-does noname :
bernd@vimes's avatar
bernd@vimes committed
248
    lastxt dup r> ! r> >cmd ;
249
: +net2o: ( "name" -- ) gen-table $[]# net2o: ;
bernd's avatar
bernd committed
250
: >table ( table -- )  last-2o 2 cells + ! ;
bernd's avatar
bernd committed
251
: net2o' ( "name" -- ) ' >body @ ;
bernd@vimes's avatar
bernd@vimes committed
252

bernd's avatar
bernd committed
253 254
: F also forth parse-name parser1 execute previous ; immediate

255 256
: un-cmd ( -- )  0. buf-state 2!  0 >o rdrop ;

257 258
Defer net2o:words

bernd@vimes's avatar
bernd@vimes committed
259 260
Vocabulary net2o-base

261
get-current also net2o-base definitions previous
bernd@vimes's avatar
bernd@vimes committed
262

bernd@vimes's avatar
bernd@vimes committed
263 264
\ Command numbers preliminary and subject to change

265 266
0 net2o: dummy ( -- ) ; \ alias
0 net2o: end-cmd ( -- ) 0 buf-state ! ;
267
+net2o: ulit ( #u -- u ) \ unsigned literal
bernd's avatar
bernd committed
268
    p@ ;
269
+net2o: slit ( #n -- n ) \ signed literal, zig-zag encoded
bernd's avatar
bernd committed
270
    ps@ ;
271
+net2o: string ( #string -- $:string ) \ string literal
bernd's avatar
bernd committed
272
    string@ ;
273
+net2o: flit ( #dfloat -- r ) \ double float literal
274
    pf@ ;
275 276
+net2o: endwith ( o:object -- ) \ last command in buffer
    n:o> ;
277 278
+net2o: oswap ( o:nest o:current -- o:current o:nest )
    n:oswap ;
279
+net2o: tru ( -- f:true ) \ true flag literal
bernd's avatar
bernd committed
280
    true ;
281
+net2o: fals ( -- f:false ) \ false flag literal
bernd's avatar
bernd committed
282
    false ;
283 284
+net2o: words ( ustart -- ) \ reflection
    64>n net2o:words ;
bernd@vimes's avatar
bernd@vimes committed
285

286
dup set-current
287

bernd's avatar
bernd committed
288
gen-table $freeze
289 290
gen-table $@ reply-table $!
' reply-table is gen-table
bernd's avatar
bernd committed
291

292 293
\ net2o assembler

294
: n2o:see-me ( -- )
295
    buf-state 2@ 2>r
bernd's avatar
bernd committed
296
    ." see-me: " dest-addr 64@ $64.
bernd's avatar
bernd committed
297
    \ tag-addr dup hex. 2@ swap hex. hex. F cr
298
    inbuf packet-data n2o:see
299
    2r> buf-state 2! ;
300

301 302
: cmdreset  cmdbuf# off ;

303
: net2o-code    cmd0source off  cmdlock lock
304
    cmdreset 1 code+ also net2o-base ;
305
comp: :, also net2o-base ;
bernd's avatar
bernd committed
306
: net2o-code0   cmd0buf cmd0source !   cmdlock lock
307
    cmdreset also net2o-base ;
308
comp: :, also net2o-base ;
309

bernd's avatar
bernd committed
310
: send-cmd ( addr u dest -- ) n64-swap { buf# }
311
    +send-cmd dest-addr 64@ 64>r set-dest
bernd's avatar
bernd committed
312
    cmd( ." send: " dest-addr 64@ $64. dup buf# n2o:see cr )
bernd's avatar
bernd committed
313
    max-size^2 1+ 0 DO
bernd's avatar
bernd committed
314
	buf# min-size I lshift u<= IF
315
	    I send-cX  cmdreset  UNLOOP
bernd's avatar
bernd committed
316 317
	    64r> dest-addr 64! EXIT  THEN
    LOOP  64r> dest-addr 64!  true !!commands!! ;
Bernd Paysan's avatar
Bernd Paysan committed
318

319 320
: cmddest ( -- dest ) cmd0source @ IF  64#0  ELSE  code-vdest
    64dup 64-0= !!no-dest!! THEN ;
bernd's avatar
bernd committed
321

bernd's avatar
bernd committed
322
: cmd ( -- )  cmdbuf# @ 2 u< ?EXIT \ don't send if cmdbuf is empty
323
    connection >o cmdbuf cmdbuf# @ cmddest send-cmd
bernd's avatar
bernd committed
324
    cmd0source @ 0= IF  code-update punch-load $off  THEN o> ;
bernd's avatar
bernd committed
325

bernd's avatar
bernd committed
326 327
also net2o-base

328
UDefer expect-reply?
329 330
' end-cmd IS expect-reply?

bernd's avatar
bernd committed
331 332
:noname  ['] end-cmd IS expect-reply? ; is init-reply

bernd's avatar
bernd committed
333
: cmd-send? ( -- )
bernd's avatar
bernd committed
334
    cmdbuf# @ IF  expect-reply? cmd connection IF  code-update THEN  THEN ;
bernd's avatar
bernd committed
335 336 337

previous

bernd's avatar
bernd committed
338 339
: acked ( -- ) \ replace key with random stuff
    state# rng$ last-ivskey @ swap move ;
340
: net2o:ok? ( -- )  o?
341 342
    tag-addr >r cmdbuf$ r@ 2!
    tag( ." tag: " tag-addr dup hex. 2@ swap hex. hex. F cr )
343
    code-vdest r> reply-dest 64! ;
344
: net2o:ok ( tag -- )
345
    timeout( cmd( ." ack: " dup hex. F cr ) )
bernd's avatar
bernd committed
346
    o 0= IF  drop EXIT  THEN
bernd's avatar
bernd committed
347 348 349
    resend0 $off
    nat( ." ok from: " ret-addr $10 xtype space dup .
    dup reply[] 2@ d0= IF ." acked"  THEN cr )
bernd's avatar
bernd committed
350
    acked  0. rot reply[] 2! ; \ clear request
351
: net2o:expect-reply ( -- )  o?
352
    timeout( cmd( ." expect: " cmdbuf$ n2o:see ) )
bernd's avatar
bernd committed
353
    cmdbuf$
354
    connection >o code-reply dup >r 2! code-vdest r> reply-dest 64! o> ;
bernd's avatar
bernd committed
355

bernd's avatar
bernd committed
356
: tag-addr? ( -- flag )
357 358
    tag-addr dup >r 2@
    ?dup-IF
bernd's avatar
bernd committed
359 360
	cmd( dest-addr 64@ $64. ." resend canned code reply " tag-addr hex. cr )
	r> reply-dest 64@ send-cmd true
361
	1 packets2 +!
bernd's avatar
bernd committed
362
    ELSE  dest-addr 64@ [ cell 4 = ] [IF] 0<> - [THEN] dup 0 r> 2! u>=  THEN ;
bernd's avatar
bernd committed
363

bernd's avatar
bernd committed
364 365
Variable throwcount

366
: do-cmd-loop ( addr u -- )
bernd's avatar
bernd committed
367
    cmd( dest-addr 64@ $64. 2dup n2o:see )
bernd's avatar
bernd committed
368
    sp@ >r throwcount off
bernd's avatar
bernd committed
369
    [: BEGIN   cmd-dispatch dup 0<=  UNTIL ;] catch
bernd's avatar
bernd committed
370
    dup IF   1 throwcount +!
bernd's avatar
bernd committed
371 372
	[: ." do-cmd-loop: " dup . .exe cr ;] $err
	dup DoError  nothrow
bernd's avatar
bernd committed
373
	buf-state @ show-offset !  n2o:see-me  show-offset on
bernd's avatar
bernd committed
374 375
	un-cmd  throwcount @ 4 < IF  >throw  THEN  THEN
    r> sp! 2drop +cmd ;
376

bernd's avatar
bernd committed
377
: cmd-loop ( addr u -- )
378
    string-stack off  object-stack off  o to connection
379
    o IF
bernd's avatar
bernd committed
380
	maxdata code+
bernd's avatar
bernd committed
381
	cmd0source off
bernd's avatar
bernd committed
382
	tag-addr? IF
383
	    2drop  >flyburst  1 packetr2 +!  EXIT  THEN
bernd's avatar
bernd committed
384
    ELSE
bernd's avatar
bernd committed
385
	cmd0buf cmd0source !
bernd's avatar
bernd committed
386
    THEN
bernd's avatar
bernd committed
387
    [: cmdreset  do-cmd-loop  cmd-send? ;] cmdlock c-section ;
bernd's avatar
bernd committed
388 389 390

' cmd-loop is queue-command

391 392
\ nested commands

bernd's avatar
bernd committed
393
: >initbuf ( addr u -- addr' u' ) tuck
bernd's avatar
bernd committed
394 395 396
    init0buf mykey-salt# + swap move dfaligned
    \ maxdata  BEGIN  2dup 2/ u<  WHILE  2/ dup $20 = UNTIL  THEN  nip
    init0buf swap mykey-salt# + 2 64s + ;
bernd's avatar
bernd committed
397

bernd's avatar
bernd committed
398 399 400
4 Constant maxnest#
User neststart#
User neststack maxnest# cells uallot drop \ nest up to 10 levels
bernd's avatar
bernd committed
401

402 403 404
: nest[ ( -- ) neststart# @ neststack @+ swap cells + !
    1 neststack +! neststack @ maxnest# u>= !!maxnest!!
    cmdbuf# @ neststart# ! ;
bernd's avatar
bernd committed
405

bernd's avatar
bernd committed
406
: cmd> ( -- addr u )
bernd's avatar
bernd committed
407
    init0buf mykey-salt# + maxdata 2/ erase
408 409 410
    cmdbuf$ neststart# @ safe/string neststart# @ cmdbuf# !
    -1 neststack +! neststack @ 0< !!minnest!!
    neststack @+ swap cells + @ neststart# ! ;
411

412
: cmd>nest ( -- addr u ) cmd> >initbuf 2dup mykey-encrypt$ ;
bernd's avatar
bernd committed
413 414
: cmd>tmpnest ( -- addr u )
    cmd> >initbuf 2dup tmpkey@ keysize umin encrypt$ ;
bernd's avatar
bernd committed
415

416 417
: do-nest ( addr u flag -- )
    buf-state 2@ 2>r validated @ >r  validated or!  do-cmd-loop
bernd's avatar
bernd committed
418 419
    r> validated !
    2r> buf-state cell+ @ IF  buf-state 2!  ELSE  2drop  THEN ;
420

bernd's avatar
bernd committed
421
: cmdnest ( addr u -- )  mykey-decrypt$
bernd's avatar
bernd committed
422
    IF  own-crypt-val do-nest  ELSE  un-cmd  THEN ;
bernd's avatar
bernd committed
423

bernd's avatar
bernd committed
424 425 426
: cmdtmpnest ( addr u -- )
    $>align tmpkey@ drop keysize decrypt$
    IF  tmp-crypt-val do-nest  ELSE  un-cmd  THEN ;
bernd's avatar
bernd committed
427

bernd@vimes's avatar
bernd@vimes committed
428 429
\ net2o assembler stuff

430 431
also net2o-base definitions

bernd's avatar
bernd committed
432
: maxtiming ( -- n )  maxstring timestats - dup timestats mod - ;
bernd's avatar
bernd committed
433 434 435
: $, ( addr u -- )  string dup >r n>64 cmd,
    r@ maxstring u>= !!stringfit!!
    cmdbuf$ + r@ move   r> cmdbuf# +! ;
436
: lit, ( u -- )  ulit cmd, ;
bernd's avatar
bernd committed
437
: slit, ( n -- )  slit n>zz cmd, ;
bernd's avatar
bernd committed
438
: nlit, ( n -- )  n>64 slit, ;
439
: ulit, ( u -- )  u>64 lit, ;
440
: float, ( r -- )  flit flit, ;
441
: flag, ( flag -- ) IF tru ELSE fals THEN ;
442
: (end-code) ( -- ) expect-reply? cmd  cmdlock unlock ;
bernd's avatar
bernd committed
443
: end-code ( -- ) (end-code) previous ;
444
comp: :, previous ;
bernd's avatar
bernd committed
445 446
: push-cmd ( -- )
    end-cmd ['] end-cmd IS expect-reply? cmdbuf$ push-reply ;
447

448
dup set-current previous
bernd@vimes's avatar
bernd@vimes committed
449

bernd's avatar
bernd committed
450 451 452 453 454 455 456 457
[IFDEF] 64bit
    ' noop Alias 2*64>n immediate
    ' noop Alias 3*64>n immediate
[ELSE]
    : 2*64>n ( 64a 64b -- na nb ) 64>n >r 64>n r> ;
    : 3*64>n ( 64a 64b 64c -- na nb nc ) 64>n >r 64>n >r 64>n r> r> ;
[THEN]

bernd@vimes's avatar
bernd@vimes committed
458 459
\ commands to read and write files

bernd's avatar
bernd committed
460
also net2o-base definitions
461
$10 net2o: <req ( -- ) ; \ stub: push own id in reply
bernd's avatar
bernd committed
462 463
+net2o: req> ( -- ) endwith ; \ generic: pop own id in reply
+net2o: push-lit ( u -- ) \ push unsigned literal into answer packet
bernd's avatar
bernd committed
464 465 466 467 468 469
    lit, ;
' push-lit alias push-char
+net2o: push-slit ( n -- ) \ push singed literal into answer packet
    slit, ;
+net2o: push-$ ( $:string -- ) \ push string into answer packet
    $> $, ;
470 471 472
+net2o: push-float ( r -- ) \ push floating point number
    float, ;
+net2o: push' ( #cmd -- ) \ push command into answer packet
bernd's avatar
bernd committed
473
    p@ cmd, ;
474
+net2o: ok ( utag -- ) \ tagged response
bernd's avatar
bernd committed
475
    64>n net2o:ok ;
476
+net2o: ok? ( utag -- ) \ request tagged response
bernd's avatar
bernd committed
477 478
    net2o:ok? lit, ok ;
\ Use ko instead of throw for not acknowledge (kudos to Heinz Schnitter)
479
+net2o: ko ( uerror -- ) \ receive error message
bernd's avatar
bernd committed
480
    throw ;
bernd's avatar
bernd committed
481

bernd's avatar
bernd committed
482 483
\ inspection

484 485
+net2o: token ( $:token n -- )
    64>n 0 .r ." :" $> type space ; \ stub
bernd's avatar
bernd committed
486

487 488
:noname ( start -- )
    token-table $@ 2 pick cells safe/string bounds U+DO
bernd's avatar
bernd committed
489 490
	I @ ?dup-IF
	    >net2o-name dup $A0 + maxstring < IF
491
		2 pick ulit, [: type ." (-)" ;] $tmp $, token
bernd's avatar
bernd committed
492
	    ELSE  2drop  THEN
493 494
	THEN  1+
    cell +LOOP  drop ; IS net2o:words
bernd's avatar
bernd committed
495

bernd's avatar
bernd committed
496 497
\ setup connection class

bernd's avatar
bernd committed
498
gen-table $freeze
499 500
gen-table $@ setup-table $!
' setup-table is gen-table
bernd's avatar
bernd committed
501

502
$20 net2o: emit ( xc -- ) \ emit character on server log
bernd's avatar
bernd committed
503
    64>n xemit ;
bernd's avatar
bernd committed
504
+net2o: type ( $:string -- ) \ type string on server log
505
    $> F type ;
bernd's avatar
bernd committed
506
+net2o: . ( u -- ) \ print number on server log
bernd's avatar
bernd committed
507
    64. ;
bernd's avatar
bernd committed
508 509
+net2o: f. ( -- ) \ print fp number on server log
    F f. ;
510
+net2o: cr ( -- ) \ newline on server log
bernd's avatar
bernd committed
511
    F cr ;
512
+net2o: see-me ( -- ) \ see received commands on server log
bernd's avatar
bernd committed
513 514
    n2o:see-me ;

bernd's avatar
bernd committed
515
+net2o: nest ( $:string -- ) \ nested (self-encrypted) command
516
    $> cmdnest ;
bernd's avatar
bernd committed
517
+net2o: tmpnest ( $:string -- ) \ nested (temporary encrypted) command
518
    $> cmdtmpnest ;
bernd@vimes's avatar
bernd@vimes committed
519

bernd's avatar
bernd committed
520 521
: ]nest$  ( -- )  end-cmd cmd>nest $, ;
: ]nest  ( -- )  ]nest$ push-$ push' nest ;
bernd's avatar
bernd committed
522
: ]tmpnest ( -- )  end-cmd cmd>tmpnest $, tmpnest ;
bernd's avatar
bernd committed
523

524
+net2o: new-data ( addr addr u -- ) \ create new data mapping
525 526
    o 0<> tmp-crypt? and own-crypt? or IF  64>n  n2o:new-data  EXIT  THEN
    64drop 64drop 64drop  un-cmd ;
527
+net2o: new-code ( addr addr u -- ) \ crate new code mapping
528 529
    o 0<> tmp-crypt? and own-crypt? or IF  64>n  n2o:new-code  EXIT  THEN
    64drop 64drop 64drop  un-cmd ;
530
+net2o: request-done ( ureq -- ) 64>n \ signal request is completed
bernd's avatar
bernd committed
531
    o 0<> own-crypt? and IF  n2o:request-done  ELSE  drop  THEN ;
532
+net2o: set-rtdelay ( utimestamp -- ) \ set round trip delay
533 534 535
    o IF  rtdelay!  EXIT  THEN
    own-crypt? IF
	64dup cookie>context?
536
	IF  >o rdrop  o to connection
537
	    ticker 64@ recv-tick 64! rtdelay! \ time stamp of arrival
538
	    EXIT
539
	ELSE \ just check if timeout didn't expire
540
	    ticker 64@ connect-timeout# 64- 64u< 0= ?EXIT
bernd's avatar
bernd committed
541
	THEN
542
    ELSE  64drop  THEN  un-cmd ;
bernd's avatar
bernd committed
543

bernd's avatar
bernd committed
544
: n2o:create-map
545
    { 64: addrs ucode udata 64: addrd -- addrd ucode udata addrs }
bernd's avatar
bernd committed
546 547
    addrs lit, addrd lit, ucode ulit, new-code
    addrs ucode n>64 64+ lit, addrd ucode n>64 64+ lit, udata ulit, new-data
bernd's avatar
bernd committed
548 549
    addrd ucode udata addrs ;

bernd's avatar
bernd committed
550
+net2o: store-key ( $:string -- ) $> \ store key
551
    o 0= IF  ." don't store key, o=0: " .nnb F cr un-cmd  EXIT  THEN
552
    own-crypt? IF
bernd's avatar
bernd committed
553
	key( ." store key: o=" o hex. 2dup .nnb F cr )
bernd's avatar
bernd committed
554 555
	2dup do-keypad sec!
	crypto-key sec!
556
    ELSE  ." don't store key: o=" o hex. .nnb F cr  THEN ;
557

558
+net2o: map-request ( addrs ucode udata -- ) \ request mapping
bernd's avatar
bernd committed
559
    2*64>n
bernd's avatar
bernd committed
560
    nest[
561
    ?new-mykey ticker 64@ lit, set-rtdelay
bernd's avatar
bernd committed
562 563
    max-data# umin swap max-code# umin swap
    2dup + n2o:new-map n2o:create-map
bernd's avatar
bernd committed
564
    keypad keysize $, store-key  stskc KEYSIZE erase
565 566
    ]nest  n2o:create-map  neststack @ IF  ]tmpnest  THEN
    64drop 2drop 64drop ;
bernd's avatar
bernd committed
567

568
+net2o: disconnect ( -- ) \ close connection
bernd's avatar
bernd committed
569
    o 0= ?EXIT n2o:dispose-context un-cmd ;
570
+net2o: set-tick ( uticks -- ) \ adjust time
bernd's avatar
bernd committed
571
    adjust-ticks ;
572
+net2o: get-tick ( -- ) \ request time adjust
bernd's avatar
bernd committed
573
    ticks lit, set-tick ;
bernd's avatar
bernd committed
574

bernd's avatar
bernd committed
575 576
net2o-base

577 578
\ crypto functions

bernd's avatar
bernd committed
579
+net2o: receive-key ( $:string -- ) $> \ receive a key
580 581
    crypt( ." Received key: " tmpkey@ .nnb F cr )
    tmp-crypt? IF  net2o:receive-key  ELSE  2drop  THEN ;
582
+net2o: key-request ( -- ) \ request a key
583 584
    crypt( ." Nested key: " tmpkey@ .nnb F cr )
    nest[ pkc keysize $, receive-key ;
bernd's avatar
bernd committed
585
+net2o: receive-tmpkey ( $:string -- ) $> \ receive emphemeral key
586
    net2o:receive-tmpkey ;
587
+net2o: tmpkey-request ( -- ) \ request ephemeral key
588
    stpkc keysize $, receive-tmpkey ;
589
+net2o: update-key ( -- ) \ update secrets
590
    net2o:update-key ;
bernd's avatar
bernd committed
591
+net2o: gen-ivs ( $:string -- ) \ generate IVs
592
    $> ivs-strings receive-ivs ;
593

594 595
\ nat traversal functions

bernd's avatar
bernd committed
596
+net2o: punch ( $:string -- ) \ punch NAT traversal hole
597
    $> net2o:punch ;
bernd's avatar
bernd committed
598 599
+net2o: punch-load, ( $:string -- ) \ use for punch payload: nest it
    $> punch-load $! ;
bernd's avatar
bernd committed
600
+net2o: punch-done ( -- ) \ punch received
bernd's avatar
bernd committed
601 602 603
    o 0<> own-crypt? and IF
	return-addr return-address $10 move  resend0 $off
    THEN ;
604

bernd's avatar
bernd committed
605
: cookie, ( -- )  add-cookie lit, set-rtdelay ;
bernd's avatar
bernd committed
606
: request, ( -- )  next-request ulit, request-done ;
bernd's avatar
bernd committed
607

bernd's avatar
bernd committed
608
: gen-punch ( -- )
bernd's avatar
bernd committed
609
    my-ip$ [: $, punch ;] $[]map ;
610 611 612

: cookie+request ( -- )  nest[ cookie, request, ]nest ;

bernd's avatar
bernd committed
613
: gen-punchload ( -- )
bernd's avatar
bernd committed
614
    nest[ cookie, punch-done request, ]nest$ punch-load, ;
615 616 617 618

+net2o: punch? ( -- ) \ Request punch addresses
    gen-punch ;

619 620 621 622 623 624 625 626 627 628 629
\ create commands to send back

: all-ivs ( -- ) \ Seed and gen all IVS
    state# rng$ 2dup $, gen-ivs ivs-strings send-ivs ;

+net2o: >time-offset ( n -- ) \ set time offset
    o IF  time-offset 64!  ELSE  64drop  THEN ;
: time-offset! ( -- )  ticks 64dup lit, >time-offset time-offset 64! ;

+net2o: gen-reply ( -- ) \ generate a key request reply reply
    [: crypt( ." Reply key: " tmpkey@ .nnb F cr )
bernd's avatar
bernd committed
630
      nest[ pkc keysize $, receive-key update-key all-ivs
631
      cookie+request time-offset! ]tmpnest
632 633
      push-cmd ;]  IS expect-reply? ;

bernd's avatar
bernd committed
634 635 636 637 638 639
+net2o: gen-punch-reply ( -- )  o? \ generate a key request reply reply
    [: crypt( ." Reply key: " tmpkey@ .nnb F cr )
      nest[ pkc keysize $, receive-key update-key all-ivs
      gen-punchload gen-punch time-offset! ]tmpnest
      push-cmd ;]  IS expect-reply? ;

640 641
\ everything that follows here can assume to have a connection context

bernd's avatar
bernd committed
642
gen-table $freeze
643 644
gen-table $@ context-table $!
' context-table is gen-table
bernd's avatar
bernd committed
645

646 647
\ file functions

648
$40 net2o: file-id ( uid -- o:file )
649
    64>n state-addr n:>o ;
bernd's avatar
bernd committed
650
fs-table >table
651 652 653 654

reply-table $@ fs-table $!
' fs-table is gen-table

bernd's avatar
bernd committed
655 656
net2o' <req net2o: <req-file ( -- ) fs-id @ ulit, file-id ;
net2o' emit net2o: open-file ( $:string mode -- ) \ open file with mode
657 658 659 660 661
    64>n $> rot fs-open ;
+net2o: close-file ( -- ) \ close file
    fs-close ;
+net2o: set-size ( size -- ) \ set size attribute of current file
    track( ." file <" fs-id @ 0 .r ." > size: " 64dup 64. F cr ) size! ;
662
+net2o: set-seek ( useek -- ) \ set seek attribute of current file
663
    track( ." file <" fs-id @ 0 .r ." > seek: " 64dup 64. F cr ) seekto! ;
664
+net2o: set-limit ( ulimit -- ) \ set limit attribute of current file
665
    track( ." file <" fs-id @ 0 .r ." > seek to: " 64dup 64. F cr ) limit-min! ;
666
+net2o: set-stat ( umtime umod -- ) \ set time and mode of current file
bernd's avatar
bernd committed
667
    64>n n2o:set-stat ;
bernd's avatar
bernd committed
668 669
+net2o: get-size ( -- )
    fs-size 64@ lit, set-size ;
bernd's avatar
bernd committed
670
+net2o: get-stat ( -- ) \ request stat of current file
bernd's avatar
bernd committed
671
    n2o:get-stat >r lit, r> ulit, set-stat ;
672

bernd's avatar
bernd committed
673
gen-table $freeze
674 675
' context-table is gen-table

676
+net2o: set-blocksize ( n -- ) \ set blocksize
bernd's avatar
bernd committed
677
    64>n blocksize! ;
678
+net2o: set-blockalign ( n -- ) \ set block alignment
bernd's avatar
bernd committed
679
    64>n pow2?  blockalign ! ;
680
+net2o: close-all ( -- ) \ close all files
bernd's avatar
bernd committed
681
    n2o:close-all ;
682

bernd's avatar
bernd committed
683
: blocksize! ( n -- )  dup ulit, set-blocksize blocksize! ;
684
: blockalign! ( n -- )  pow2? dup ulit, set-blockalign blockalign ! ;
bernd's avatar
bernd committed
685

bernd's avatar
bernd committed
686 687
\ better slurping

688
:noname ( uid useek -- ) 64>r ulit, file-id
689
    64r> lit, set-seek endwith ; is do-track-seek
bernd's avatar
bernd committed
690

691
+net2o: set-top ( utop flag -- ) \ set top, flag is true when all data is sent
bernd's avatar
bernd committed
692 693 694
    >r 64>n r> data-rmap @ >o over dest-top @ <> and dest-end or! dest-top! o> ;
+net2o: slurp ( -- ) \ slurp in tracked files
    n2o:slurp swap ulit, flag, set-top
695
    ['] do-track-seek n2o:track-all-seeks net2o:send-chunks ;
bernd's avatar
bernd committed
696

bernd's avatar
bernd committed
697 698
\ flow control functions

699
$50 net2o: ack-addrtime ( utime addr -- ) \ packet at addr received at time
bernd's avatar
bernd committed
700
    net2o:ack-addrtime ;
701
+net2o: ack-resend ( flag -- ) \ set resend toggle flag
bernd's avatar
bernd committed
702
    64>n  net2o:ack-resend ;
703
+net2o: set-rate ( urate udelta-t -- ) \ set rate 
704
    cookie? IF  net2o:set-rate
705
    ELSE  64drop 64drop ns/burst dup @ 2* 2* swap !  THEN ;
706
+net2o: resend-mask ( addr umask -- ) \ resend mask blocks starting at addr
bernd's avatar
bernd committed
707
    2*64>n net2o:resend-mask net2o:send-chunks ;
708
+net2o: track-timing ( -- ) \ track timing
bernd's avatar
bernd committed
709
    net2o:track-timing ;
bernd's avatar
bernd committed
710
+net2o: rec-timing ( $:string -- ) \ recorded timing
711
    $> net2o:rec-timing ;
712
+net2o: send-timing ( -- ) \ request recorded timing
bernd's avatar
bernd committed
713 714
    net2o:timing$ maxtiming umin tuck $,
    net2o:/timing rec-timing ;
715
+net2o: ack-b2btime ( utime addr -- ) \ burst-to-burst time at packet addr
bernd's avatar
bernd committed
716
    net2o:ack-b2btime ;
717
+net2o: ack-cookies ( ucookie addr umask -- ) \ acknowledge cookie
bernd's avatar
bernd committed
718
    [IFUNDEF] 64bit 64>r 64>n 64r> [THEN]
bernd's avatar
bernd committed
719
    data-map @ cookie+ 64over 64over 64= 0= IF
bernd's avatar
bernd committed
720
	." cookies don't match! " 64over $64. 64dup $64. F cr
bernd's avatar
bernd committed
721 722
    THEN
    64= cookie-val and validated or! ;
723
+net2o: ack-flush ( addr -- ) \ flushed to addr
bernd's avatar
bernd committed
724
    64>n net2o:rewind-sender-partial ;
725
+net2o: set-head ( addr -- ) \ set head
bernd's avatar
bernd committed
726
    64>n data-rmap @ .dest-head umax! ;
727
+net2o: timeout ( uticks -- ) \ timeout request
bernd's avatar
bernd committed
728
    net2o:timeout  data-map @ .dest-tail @ ulit, set-head ;
bernd's avatar
bernd committed
729

bernd's avatar
bernd committed
730
\ profiling, nat traversal
bernd's avatar
bernd committed
731

732
$60 net2o: !time ( -- ) \ start timer
bernd's avatar
bernd committed
733
    F !time init-timer ;
734
+net2o: .time ( -- ) \ print timer to server log
bernd's avatar
bernd committed
735
    F .time .packets profile( .times ) ;
bernd's avatar
bernd committed
736

bernd's avatar
bernd committed
737
+net2o: set-ip ( $:string -- ) \ set address information
738
    $> setip-xt perform ;
739
+net2o: get-ip ( -- ) \ request address information
bernd's avatar
bernd committed
740
    >sockaddr $, set-ip [: $, set-ip ;] n2oaddrs ;
741

bernd's avatar
bernd committed
742 743 744
: net2o:gen-resend ( -- )
    recv-flag @ invert resend-toggle# and ulit, ack-resend ;
: net2o:ackflush ( n -- ) ulit, ack-flush ;
745
: n2o:done ( -- )  slurp next-request filereq# ! ;
bernd's avatar
bernd committed
746 747

: rewind ( -- )
bernd's avatar
bernd committed
748
    data-rmap @ >o dest-back @ do-slurp @ umax o> net2o:ackflush ;
bernd's avatar
bernd committed
749

750 751
\ safe initialization

752 753 754 755
net2o-base

: lit<   lit, push-lit ;
: slit<  slit, push-slit ;
bernd's avatar
bernd committed
756
:noname ( throwcode -- )
bernd's avatar
bernd committed
757
    server? IF
758
	dup  IF  dup nlit, ko end-cmd
759
	    ['] end-cmd IS expect-reply? (end-code)  THEN
bernd's avatar
bernd committed
760
    THEN  throw ; IS >throw
761

762
set-current previous
bernd@vimes's avatar
bernd@vimes committed
763

764 765
also net2o-base

bernd's avatar
bernd committed
766 767 768
: open-tracked-file ( addr u mode --)
    open-file <req get-size get-stat req> ;

bernd's avatar
bernd committed
769
: n2o:copy ( addrsrc us addrdest ud -- )
bernd's avatar
bernd committed
770 771
    file-reg# @ ulit, file-id
    2swap $, r/o ulit, open-tracked-file  endwith
bernd's avatar
bernd committed
772 773 774
    file-reg# @ save-to
    1 file-reg# +! ;

775 776 777
: seek! ( pos id -- ) >r d>64
    64dup r@ state-addr .fs-seek 64!
    r> ulit, file-id lit, set-seek endwith ;
bernd's avatar
bernd committed
778

779 780 781
: limit! ( pos id -- ) >r d>64
    r@ ulit, file-id 64dup lit, set-limit endwith
    r> init-limit! ;
bernd's avatar
bernd committed
782

bernd's avatar
bernd committed
783
file-reg# off
bernd's avatar
bernd committed
784

785
previous
786

787 788
\ client side timing

bernd's avatar
bernd committed
789 790
: ack-size ( -- )  1 acks +!
    recv-tick 64@ 64dup lastb-ticks 64!@ 64- max-dticks 64max! ;
bernd's avatar
bernd committed
791
: ack-first ( -- )
bernd's avatar
bernd committed
792 793 794
    lastb-ticks 64@ firstb-ticks 64@ 64- delta-ticks 64+!
    recv-tick 64@ 64dup firstb-ticks 64!  64dup lastb-ticks 64!
    last-rtick 64!  recv-addr 64@ last-raddr 64! ;
795

bernd's avatar
bernd committed
796
: ack-timing ( n -- )
bernd's avatar
bernd committed
797
    b2b-toggle# and  IF  ack-first  ELSE  ack-size  THEN ;
798

Bernd Paysan's avatar
Bernd Paysan committed
799
also net2o-base
800

801
: setrate-limit ( rate -- rate' )
bernd's avatar
bernd committed
802
    \ do not change requested rate by more than a factor 2
803 804 805
    last-rate 64@
    64dup 64-0<> IF  64tuck 64-2* 64min 64swap 64-2/ 64max  ELSE  64drop  THEN
    64dup last-rate 64! ;
806

807
: >rate ( -- )  delta-ticks 64@ 64-0= acks @ 0= or ?EXIT
bernd's avatar
bernd committed
808
    recv-tick 64@ 64dup burst-ticks 64!@ 64dup 64-0<> IF
bernd's avatar
bernd committed
809
	64- max-dticks 64@ tick-init 1+ n>64 64* 64max 64>r
810
	delta-ticks 64@ tick-init 1+ acks @ 64*/ setrate-limit
bernd's avatar
bernd committed
811
	lit, 64r> lit, set-rate
bernd's avatar
bernd committed
812
    ELSE
bernd's avatar
bernd committed
813
	64drop 64drop
bernd's avatar
bernd committed
814
    THEN
bernd's avatar
bernd committed
815
    delta-ticks 64off  max-dticks 64off  acks off ;
Bernd Paysan's avatar
Bernd Paysan committed
816

817
: net2o:acktime ( -- )
818
    recv-addr 64@ recv-tick 64@ time-offset 64@ 64-
bernd's avatar
bernd committed
819
    timing( 64>r 64dup $64. 64r> 64dup 64. ." acktime" F cr )
820 821
    lit, lit, ack-addrtime ;
: net2o:b2btime ( -- )
822
    last-raddr 64@ last-rtick 64@ 64dup 64-0=
bernd's avatar
bernd committed
823 824
    IF  64drop 64drop
    ELSE  time-offset 64@ 64- lit, lit, ack-b2btime  THEN ;
bernd's avatar
bernd committed
825

826 827
\ ack bits, new code

828 829 830
: ack-cookie, ( map bits n -- ) [ 8 cells ]L * maxdata *
    2dup 2>r rot >r swap u>64 r> cookie+
    lit, 2r> ulit, ulit, ack-cookies ;
831

bernd's avatar
bernd committed
832
: net2o:ack-cookies ( -- )  data-rmap @ { map }
bernd's avatar
bernd committed
833
    map .data-ackbits-buf $@
bernd's avatar
bernd committed
834 835 836 837 838
    bounds ?DO
	\ map I 2@ ack-cookie,
	I 2 cells + 64@ lit,
	I 2@ [ 8 cells ]L * maxdata * ulit, ulit, ack-cookies
    [ 2 cells 64'+ ]L +LOOP
839
    map .data-ackbits-buf $off ;
bernd's avatar
bernd committed
840

bernd's avatar
bernd committed
841 842
\ client side acknowledge

843
: net2o:genack ( -- )
bernd's avatar
bernd committed
844
    net2o:ack-cookies  net2o:b2btime  net2o:acktime  >rate ;
845

bernd's avatar
bernd committed
846
: !rdata-tail ( -- )
bernd's avatar
bernd committed
847
    data-rmap @ >o
bernd's avatar
bernd committed
848 849
    data-ack# @ bytes>addr dest-top 2@ umin umin
    dest-tail @ umax dup dest-tail !@ o>
bernd's avatar
bernd committed
850
    u> IF  net2o:save& 64#0 burst-ticks 64!  THEN ;
bernd's avatar
bernd committed
851
: receive-flag ( -- flag )  recv-flag @ resend-toggle# and 0<> ;
bernd's avatar
bernd committed
852

bernd's avatar
bernd committed
853
8 Value max-resend#
bernd's avatar
bernd committed
854

bernd's avatar
bernd committed
855
: prepare-resend ( flag -- end start acks ackm taibits )
bernd's avatar
bernd committed
856
    data-rmap @ >o
bernd's avatar
bernd committed
857
    IF    dest-head @ addr>bits bits>bytes -4 and
858
    ELSE  dest-head @ 1- addr>bits bits>bytes 1+  THEN 0 max
bernd's avatar
bernd committed
859
    dest-tail @ addr>bytes -4 and dup data-ack# umin!
bernd's avatar
bernd committed
860 861
    data-ackbits @ dest-size @ addr>bytes 1-
    dest-tail @ addr>bits o> ;
bernd's avatar
bernd committed
862 863 864

: net2o:do-resend ( flag -- )
    o 0= IF  drop EXIT  THEN  data-rmap @ 0= IF  drop EXIT  THEN
bernd's avatar
bernd committed
865
    0 swap  prepare-resend { acks ackm tailbits }
bernd's avatar
bernd committed
866
    +DO
867
	acks I ackm and + l@
bernd's avatar
bernd committed
868 869 870
	I bytes>bits tailbits u< IF
	    -1 tailbits I bytes>bits - lshift invert or
	THEN
871
	dup $FFFFFFFF <> IF
872
	    resend( ." resend: " dup hex. over hex. F cr )
bernd's avatar
bernd committed