net2o-cmd.fs 15 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

bernd's avatar
bernd committed
50
: >$ ( addr u -- $:string )
51
    string-stack $[]# 1+ string-stack $[] cell- 2! ;
bernd's avatar
bernd committed
52
: $> ( $:string -- addr u )
53 54 55 56
    string-stack $[]# 2 -
    dup 0< !!string-empty!! dup >r
    string-stack $[] 2@
    r> cells string-stack $!len ;
57

58 59
: @>$ ( addr u -- $:string addr' u' )
    bounds p@+ [IFUNDEF] 64bit nip [THEN]
bernd's avatar
bernd committed
60
    swap $200000 umin bounds ( endbuf endstring startstring )
bernd's avatar
bernd committed
61
    >r over umin dup r> over umin tuck - >$ tuck - ;
62 63 64

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

66 67 68 69 70 71 72 73 74 75 76 77 78 79
\ 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 -- )
80
    string-stack $@ bounds U+DO
81 82 83
	cr i 2@ n2o:$.
    2 cells +LOOP ;

84
\ object stack
85

bernd's avatar
bernd committed
86 87
: o-pop ( o:o1 o:x -- o1 o:x ) object-stack stack> ;
: o-push ( o1 o:x -- o:o1 o:x ) object-stack >stack ;
88 89

: n:>o ( o1 o:o2 -- o:o2 o:o1 )
90
    >o r> o-push  req? off ;
91
: n:o> ( o:o2 o:o1 -- o:o2 )
92 93 94 95
    o-pop >r o> ;
: n:oswap ( o:o1 o:o2 -- o:o2 o:o1 )
    o-pop >o r> o-push ;

96 97
\ token stack - only for decompiling

bernd's avatar
bernd committed
98 99
: t-push ( addr -- )  t-stack >stack ;
: t-pop ( -- addr )   t-stack stack> ;
100
: t# ( -- n ) t-stack $[]# ;
101

102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
\ 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! ;
122

123 124 125 126 127
\ 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
128
: net2o-crash true !!function!! ;
Bernd Paysan's avatar
Bernd Paysan committed
129

130 131
Defer gen-table
' cmd-table IS gen-table
bernd's avatar
bernd committed
132

bernd's avatar
bernd committed
133 134 135 136 137
: $freeze ( addr -- )
    \G copy string to dictionary
    >r r@ $@  align here r> !
    dup , here swap dup allot move align ;

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

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

144
-6 dup 1+ 1 and cell 4 = and - cells 0 +field net2o.name
145 146
drop

bernd's avatar
bernd committed
147
: >net2o-name ( addr -- addr' u )
148
    net2o.name body> name>string ;
149 150
: >net2o-sig ( addr -- addr' u )
    net2o.name 3 cells + $@ ;
bernd's avatar
bernd committed
151
: .net2o-num ( off -- )  cell/ '<' emit 0 .r '>' emit space ;
bernd's avatar
bernd committed
152

bernd's avatar
bernd committed
153
: (net2o-see) ( addr index -- )  dup >r + @
bernd's avatar
bernd committed
154
    dup 0<> IF
155
	net2o.name
156
	dup 2 cells + @ ?dup-IF  @ token-table @ t-push token-table !  THEN
bernd's avatar
bernd committed
157 158
	body> .name
    ELSE  drop r@ .net2o-num  THEN  rdrop ;
159

160 161
: .net2o-name ( n -- )  cells >r
    o IF  token-table  ELSE  setup-table  THEN $@ r@ u<=
bernd's avatar
bernd committed
162
    IF  drop r> .net2o-num  EXIT  THEN  r> (net2o-see) ;
bernd's avatar
bernd committed
163 164
: .net2o-name' ( n -- )  cells >r
    o IF  token-table  ELSE  setup-table  THEN $@ r@ u<=
bernd's avatar
bernd committed
165
    IF  drop r> .net2o-num  EXIT  THEN  r@ + @
bernd's avatar
bernd committed
166
    dup 0<> IF
bernd's avatar
bernd committed
167 168
	net2o.name body> .name
    ELSE  drop r@ .net2o-num  THEN  rdrop ;
bernd's avatar
bernd committed
169

170
: net2o-see ( cmd -- ) hex[
171 172
    case
	0 of  ." end-code" cr 0. buf-state 2!  endof
bernd's avatar
bernd committed
173
	1 of  p@ 64. ." lit, "  endof
bernd's avatar
bernd committed
174
	2 of  ps@ s64. ." slit, " endof
bernd's avatar
bernd committed
175
	3 of  string@  n2o.string  endof
176
	4 of  pf@ f. ." float, " endof
177
	5 of  ." endwith " cr  t# IF  t-pop  token-table !  THEN  endof
178
	6 of  ." oswap " cr token-table @ t-pop token-table ! t-push  endof
179
	$10 of ." push' " p@ .net2o-name  endof
bernd's avatar
bernd committed
180
	.net2o-name
181
	0 endcase ]hex ;
182

bernd's avatar
bernd committed
183 184
Variable show-offset  show-offset on

bernd's avatar
bernd committed
185 186
sema see-lock

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

191
: n2o:see ( addr u -- )
bernd's avatar
bernd committed
192 193 194 195 196
    [: ." net2o-code"  dest-flags 1+ c@ stateless# and IF  '0' emit  THEN
      space  t-stack $off
      o IF  token-table @ >r  THEN
      [: BEGIN  cmd-see dup 0= UNTIL ;] catch
      o IF  r> token-table !  THEN  throw  2drop ;] see-lock c-section ;
197

198
: cmd-dispatch ( addr u -- addr' u' )
bernd's avatar
bernd committed
199
    buf-state 2!
bernd's avatar
bernd committed
200
    cmd@ trace( dup IF dup .net2o-name' THEN >r .s r> $.s cr ) n>cmd
bernd's avatar
bernd committed
201 202
    @ ?dup-IF  execute  ELSE
	trace( ." crashing" cr cr ) net2o-crash  THEN  buf-state 2@ ;
bernd's avatar
bernd committed
203

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

206 207
Defer >throw

bernd@vimes's avatar
bernd@vimes committed
208 209
\ commands

210 211 212 213 214 215 216 217 218 219 220
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 -- )
221
    dup maxstring u>= !!cmdfit!! cmdbuf# +! ;
222

223 224
: do-<req ( -- )  o IF  -1 req? !@ 0= IF  start-req  THEN  THEN ;
: cmd, ( 64n -- )  do-<req  cmdbuf$ + dup >r p!+ r> - cmdbuf+ ;
225 226

: net2o, @ n>64 cmd, ;
227

bernd's avatar
bernd committed
228 229
0 Value last-2o

230
: net2o-does  DOES> net2o, ;
bernd@vimes's avatar
bernd@vimes committed
231 232
: net2o: ( number "name" -- )
    ['] noop over >cmd \ allocate space in table
bernd's avatar
bernd committed
233
    Create  here to last-2o
234
    dup >r , here >r 0 , 0 , 0 , net2o-does noname :
bernd@vimes's avatar
bernd@vimes committed
235
    lastxt dup r> ! r> >cmd ;
236
: +net2o: ( "name" -- ) gen-table $[]# net2o: ;
bernd's avatar
bernd committed
237
: >table ( table -- )  last-2o 2 cells + ! ;
238
: cmdsig ( -- addr )  last-2o 3 cells + ;
bernd's avatar
bernd committed
239
: net2o' ( "name" -- ) ' >body @ ;
bernd@vimes's avatar
bernd@vimes committed
240

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

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

245 246
Defer net2o:words

247 248 249
: inherit-table ( addr u "name" -- )
    ' dup IS gen-table  execute $! ;

bernd@vimes's avatar
bernd@vimes committed
250 251
Vocabulary net2o-base

252 253
Defer do-req>

254
get-current also net2o-base definitions
bernd@vimes's avatar
bernd@vimes committed
255

bernd@vimes's avatar
bernd@vimes committed
256 257
\ Command numbers preliminary and subject to change

258 259 260 261 262 263 264 265
: ( ( "type"* "--" "type"* "rparen" -- ) ')' parse 2drop ;
comp: drop cmdsig @ IF  ')' parse 2drop  EXIT  THEN
    s" (" cmdsig $!
    BEGIN  parse-name dup  WHILE  over c@ cmdsig c$+!
	s" )" str= UNTIL  ELSE  2drop  THEN
    \ cmdsig $freeze
;

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

288
previous
289
dup set-current
290

bernd's avatar
bernd committed
291
gen-table $freeze
292
gen-table $@ inherit-table reply-table
bernd's avatar
bernd committed
293

294 295
\ net2o assembler

296 297 298
: .dest-addr ( flag -- )
    1+ c@ stateless# and 0= IF dest-addr 64@ $64. THEN ;

299
: n2o:see-me ( -- )
300
    buf-state 2@ 2>r
301 302
    ." see-me: "
    inbuf flags .dest-addr
bernd's avatar
bernd committed
303
    \ tag-addr dup hex. 2@ swap hex. hex. F cr
304
    inbuf packet-data n2o:see
305
    2r> buf-state 2! ;
306

307
: cmdreset ( -- )
308
    cmdbuf# off  o IF  req? off  THEN ;
309 310 311 312 313 314 315 316 317 318
: cmd0! ( -- )
    \g initialize a stateless command
    cmd0buf cmd0source !  stateless# outflag ! ;
: cmd! ( -- )
    \g initialize a statefull command
    cmd0source off  outflag off ;

: net2o-code ( -- )
    \g start a statefull command
    cmd!  cmdlock lock
319
    cmdreset 1 code+ also net2o-base ;
320
comp: :, also net2o-base ;
321 322 323
: net2o-code0
    \g start a stateless command
    cmd0!  cmdlock lock
324
    cmdreset also net2o-base ;
325
comp: :, also net2o-base ;
326

bernd's avatar
bernd committed
327
: send-cmd ( addr u dest -- ) n64-swap { buf# }
328
    +send-cmd dest-addr 64@ 64>r set-dest
329
    cmd( ." send: " dest-flags .dest-addr dup buf# n2o:see cr )
bernd's avatar
bernd committed
330
    max-size^2 1+ 0 DO
bernd's avatar
bernd committed
331
	buf# min-size I lshift u<= IF
332
	    I send-cX  cmdreset  UNLOOP
bernd's avatar
bernd committed
333 334
	    64r> dest-addr 64! EXIT  THEN
    LOOP  64r> dest-addr 64!  true !!commands!! ;
Bernd Paysan's avatar
Bernd Paysan committed
335

336
: cmddest ( -- dest ) cmd0source @ IF  rng@  ELSE  code-vdest
337
    64dup 64-0= !!no-dest!! THEN ;
bernd's avatar
bernd committed
338

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

bernd's avatar
bernd committed
343 344
also net2o-base

345
UDefer expect-reply?
346 347
' end-cmd IS expect-reply?

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

bernd's avatar
bernd committed
350
: cmd-send? ( -- )
bernd's avatar
bernd committed
351
    cmdbuf# @ IF  expect-reply? cmd connection IF  code-update THEN  THEN ;
bernd's avatar
bernd committed
352 353 354

previous

bernd's avatar
bernd committed
355 356
: acked ( -- ) \ replace key with random stuff
    state# rng$ last-ivskey @ swap move ;
357
: net2o:ok? ( -- )  o?
358 359
    tag-addr >r cmdbuf$ r@ 2!
    tag( ." tag: " tag-addr dup hex. 2@ swap hex. hex. F cr )
360
    code-vdest r> reply-dest 64! ;
361
: net2o:ok ( tag -- )
362
    timeout( cmd( ." ack: " dup hex. F cr ) )
bernd's avatar
bernd committed
363
    o 0= IF  drop EXIT  THEN
bernd's avatar
bernd committed
364 365 366
    resend0 $off
    nat( ." ok from: " ret-addr $10 xtype space dup .
    dup reply[] 2@ d0= IF ." acked"  THEN cr )
bernd's avatar
bernd committed
367
    acked  0. rot reply[] 2! ; \ clear request
368
: net2o:expect-reply ( -- )  o?
369
    timeout( cmd( ." expect: " cmdbuf$ n2o:see ) )
bernd's avatar
bernd committed
370
    cmdbuf$
371
    connection >o code-reply dup >r 2! code-vdest r> reply-dest 64! o> ;
bernd's avatar
bernd committed
372

bernd's avatar
bernd committed
373
: tag-addr? ( -- flag )
374 375
    tag-addr dup >r 2@
    ?dup-IF
bernd's avatar
bernd committed
376 377
	cmd( dest-addr 64@ $64. ." resend canned code reply " tag-addr hex. cr )
	r> reply-dest 64@ send-cmd true
378
	1 packets2 +!
bernd's avatar
bernd committed
379
    ELSE  dest-addr 64@ [ cell 4 = ] [IF] 0<> - [THEN] dup 0 r> 2! u>=  THEN ;
bernd's avatar
bernd committed
380

bernd's avatar
bernd committed
381 382
Variable throwcount

383
: do-cmd-loop ( addr u -- )
384
    cmd( dest-flags .dest-addr 2dup n2o:see )
bernd's avatar
bernd committed
385
    sp@ >r throwcount off
bernd's avatar
bernd committed
386
    [: BEGIN   cmd-dispatch dup 0<=  UNTIL ;] catch
bernd's avatar
bernd committed
387
    dup IF   1 throwcount +!
bernd's avatar
bernd committed
388 389
	[: ." do-cmd-loop: " dup . .exe cr ;] $err
	dup DoError  nothrow
bernd's avatar
bernd committed
390
	buf-state @ show-offset !  n2o:see-me  show-offset on
bernd's avatar
bernd committed
391 392
	un-cmd  throwcount @ 4 < IF  >throw  THEN  THEN
    r> sp! 2drop +cmd ;
393

bernd's avatar
bernd committed
394
: cmd-loop ( addr u -- )
395 396 397 398
    string-stack $off
    object-stack $off
    nest-stack $off
    o to connection
399
    o IF
bernd's avatar
bernd committed
400
	maxdata code+
bernd's avatar
bernd committed
401
	cmd0source off
bernd's avatar
bernd committed
402
	tag-addr? IF
bernd's avatar
bernd committed
403
	    2drop  ack@ .>flyburst  1 packetr2 +!  EXIT  THEN
bernd's avatar
bernd committed
404
    ELSE
405
	cmd0!
bernd's avatar
bernd committed
406
    THEN
bernd's avatar
bernd committed
407
    [: cmdreset  do-cmd-loop  cmd-send? ;] cmdlock c-section ;
bernd's avatar
bernd committed
408 409 410

' cmd-loop is queue-command

411 412
\ nested commands

bernd's avatar
bernd committed
413
: >initbuf ( addr u -- addr' u' ) tuck
bernd's avatar
bernd committed
414 415 416
    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
417

bernd's avatar
bernd committed
418
User neststart#
bernd's avatar
bernd committed
419

bernd's avatar
bernd committed
420
: nest[ ( -- ) neststart# @ nest-stack >stack
421
    cmdbuf# @ neststart# ! ;
bernd's avatar
bernd committed
422

bernd's avatar
bernd committed
423
: cmd> ( -- addr u )
bernd's avatar
bernd committed
424
    init0buf mykey-salt# + maxdata 2/ erase
425
    cmdbuf$ neststart# @ safe/string neststart# @ cmdbuf# !
bernd's avatar
bernd committed
426
    nest-stack stack> neststart# ! ;
427

428
: cmd>nest ( -- addr u ) cmd> >initbuf 2dup mykey-encrypt$ ;
bernd's avatar
bernd committed
429 430
: cmd>tmpnest ( -- addr u )
    cmd> >initbuf 2dup tmpkey@ keysize umin encrypt$ ;
bernd's avatar
bernd committed
431

432 433
: do-nest ( addr u flag -- )
    buf-state 2@ 2>r validated @ >r  validated or!  do-cmd-loop
bernd's avatar
bernd committed
434 435
    r> validated !
    2r> buf-state cell+ @ IF  buf-state 2!  ELSE  2drop  THEN ;
436

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

bernd's avatar
bernd committed
440 441 442
: cmdtmpnest ( addr u -- )
    $>align tmpkey@ drop keysize decrypt$
    IF  tmp-crypt-val do-nest  ELSE  un-cmd  THEN ;
bernd's avatar
bernd committed
443

bernd@vimes's avatar
bernd@vimes committed
444 445
\ net2o assembler stuff

446 447
also net2o-base definitions

bernd's avatar
bernd committed
448
: maxtiming ( -- n )  maxstring timestats - dup timestats mod - ;
bernd's avatar
bernd committed
449 450 451
: $, ( addr u -- )  string dup >r n>64 cmd,
    r@ maxstring u>= !!stringfit!!
    cmdbuf$ + r@ move   r> cmdbuf# +! ;
bernd's avatar
bernd committed
452 453
: lit, ( 64u -- )  ulit cmd, ;
: slit, ( 64n -- )  slit n>zz cmd, ;
bernd's avatar
bernd committed
454
: nlit, ( n -- )  n>64 slit, ;
455
: ulit, ( u -- )  u>64 lit, ;
456
: float, ( r -- )  flit cmdbuf$ + dup >r pf!+ r> - cmdbuf+ ;
457
: flag, ( flag -- ) IF tru ELSE fals THEN ;
458
: (end-code) ( -- ) expect-reply? cmd  cmdlock unlock ;
bernd's avatar
bernd committed
459
: end-code ( -- ) (end-code) previous ;
460
comp: :, previous ;
bernd's avatar
bernd committed
461 462
: push-cmd ( -- )
    end-cmd ['] end-cmd IS expect-reply? cmdbuf$ push-reply ;
463

464
dup set-current previous
bernd@vimes's avatar
bernd@vimes committed
465

bernd's avatar
bernd committed
466 467 468 469 470 471 472 473
[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]

474
\ commands to reply
bernd@vimes's avatar
bernd@vimes committed
475

bernd's avatar
bernd committed
476
also net2o-base definitions
477 478
$10 net2o: push' ( #cmd -- ) \ push command into answer packet
    p@ cmd, ;
bernd's avatar
bernd committed
479
+net2o: push-lit ( u -- ) \ push unsigned literal into answer packet
bernd's avatar
bernd committed
480 481 482 483 484 485
    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
    $> $, ;
486 487 488
+net2o: push-float ( r -- ) \ push floating point number
    float, ;
+net2o: ok ( utag -- ) \ tagged response
bernd's avatar
bernd committed
489
    64>n net2o:ok ;
490
+net2o: ok? ( utag -- ) \ request tagged response
bernd's avatar
bernd committed
491 492
    net2o:ok? lit, ok ;
\ Use ko instead of throw for not acknowledge (kudos to Heinz Schnitter)
493
+net2o: ko ( uerror -- ) \ receive error message
bernd's avatar
bernd committed
494
    throw ;
495 496
+net2o: nest ( $:string -- ) \ nested (self-encrypted) command
    $> cmdnest ;
bernd's avatar
bernd committed
497 498
+net2o: request-done ( ureq -- ) 64>n \ signal request is completed
    o 0<> own-crypt? and IF  n2o:request-done  ELSE  drop  THEN ;
bernd's avatar
bernd committed
499

bernd's avatar
bernd committed
500 501
\ inspection

502
+net2o: token ( $:token n -- ) 64drop $> 2drop ; \ stub
bernd's avatar
bernd committed
503

504 505
:noname ( start -- )
    token-table $@ 2 pick cells safe/string bounds U+DO
bernd's avatar
bernd committed
506
	I @ ?dup-IF
507 508 509 510
	    dup >net2o-sig 2>r >net2o-name
	    dup $A0 + maxstring < IF
		2 pick ulit, 2r> 2swap [: type type ;] $tmp $, token
	    ELSE  2drop rdrop rdrop  THEN
511 512
	THEN  1+
    cell +LOOP  drop ; IS net2o:words
bernd's avatar
bernd committed
513

bernd's avatar
bernd committed
514
gen-table $freeze
515

bernd's avatar
bernd committed
516 517 518 519
0 [IF]
Local Variables:
forth-local-words:
    (
520
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
bernd's avatar
bernd committed
521
      "[ \t\n]" t name (font-lock-function-name-face . 3))
bernd's avatar
bernd committed
522
     ("[a-z\-0-9]+(" immediate (font-lock-comment-face . 1)
bernd's avatar
bernd committed
523
      ")" nil comment (font-lock-comment-face . 1))
bernd's avatar
bernd committed
524
    )
bernd's avatar
bernd committed
525 526
forth-local-indent-words:
    (
527
     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
bernd's avatar
bernd committed
528 529
     (("[:") (0 . 1) (0 . 1) immediate)
     ((";]") (-1 . 0) (0 . -1) immediate)
bernd's avatar
bernd committed
530
    )
bernd's avatar
bernd committed
531 532
End:
[THEN]