Check-in [1553e00b7f]
Not logged in
Home Timeline Files Branches Tags Tickets Wiki Login Impressum Datenschutzerklärung

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Rename of deque to stack words
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1553e00b7fbdb2f11ffba459e8d8249c7a794ee0
User & Date: bernd 2016-12-02 21:35:28.581
Context
2016-12-04
01:14
Rename temporary files when downloading hashs check-in: 25cf75b4fa user: bernd tags: trunk
2016-12-02
21:35
Rename of deque to stack words check-in: 1553e00b7f user: bernd tags: trunk
17:59
Bump version number check-in: ab81c21966 user: bernd tags: trunk, 0.2.0-20161202
Changes
Unified Diff Ignore Whitespace Patch
Changes to config.fs.
︙︙
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33


Vocabulary config
' config >body Value config-wl

Variable config-recognizer
\G The config recognizer

' rec:string ' rec:num ' rec:float 3 config-recognizer deque!

: .config-err ( -- )
    ." unknown config variable: '" source type ." '" cr ;
: exec-config ( .. addr u char xt1 xt2 -- ) >r >r
    [: >r type r> emit ;] $tmp config-wl find-name-in
    ?dup-IF  execute r> execute rdrop
    ELSE rdrop r> execute .config-err THEN ;








|








19
20
21
22
23
24
25
26
27
28
29
30
31
32
33


Vocabulary config
' config >body Value config-wl

Variable config-recognizer
\G The config recognizer

' rec:string ' rec:num ' rec:float 3 config-recognizer set-stack

: .config-err ( -- )
    ." unknown config variable: '" source type ." '" cr ;
: exec-config ( .. addr u char xt1 xt2 -- ) >r >r
    [: >r type r> emit ;] $tmp config-wl find-name-in
    ?dup-IF  execute r> execute rdrop
    ELSE rdrop r> execute .config-err THEN ;
︙︙
Changes to net2o-cmd.fs.
︙︙
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

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

\ object stack

: o-pop ( o:o1 o:x -- o1 o:x ) object-stack deque> ;
: o-push ( o1 o:x -- o:o1 o:x ) object-stack >deque ;

: n:>o ( o1 o:o2 -- o:o2 o:o1 )
    >o r> o-push  o IF  1 req? !  THEN ;
: n:o> ( o:o2 o:o1 -- o:o2 )
    o-pop >r o> ;
: n:oswap ( o:o1 o:o2 -- o:o2 o:o1 )
    o-pop >o r> o-push ;

\ token stack - only for decompiling

: t-push ( addr -- )  t-stack >deque ;
: t-pop ( -- addr )   t-stack deque> ;
: t# ( -- n ) t-stack $[]# ;

\ 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>








|
|










|
|








126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

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

\ object stack

: o-pop ( o:o1 o:x -- o1 o:x ) object-stack stack> ;
: o-push ( o1 o:x -- o:o1 o:x ) object-stack >stack ;

: n:>o ( o1 o:o2 -- o:o2 o:o1 )
    >o r> o-push  o IF  1 req? !  THEN ;
: n:o> ( o:o2 o:o1 -- o:o2 )
    o-pop >r o> ;
: n:oswap ( o:o1 o:o2 -- o:o2 o:o1 )
    o-pop >o r> o-push ;

\ token stack - only for decompiling

: t-push ( addr -- )  t-stack >stack ;
: t-pop ( -- addr )   t-stack stack> ;
: t# ( -- n ) t-stack $[]# ;

\ 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>
︙︙
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643

2 Constant fwd# \ maximum 14 bits = 16kB

: nest$ ( -- addr u )  cmdbuf$ neststart# @ safe/string ;

: cmd-resolve> ( -- addr u )
    nest$ over >r dup n>64 cmdtmp$ dup fwd# u> !!stringfit!!
    r> over - swap move
    nest-stack deque> neststart# ! ;

also net2o-base

: +zero16 ( -- ) "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" +cmdbuf ;
: sign[ ( -- ) neststart# @ nest-stack >deque
    string "\x80\x00" +cmdbuf cmdbuf$ nip neststart# ! ;
: nest[ ( -- ) sign[ +zero16 ; \ add space for IV
: ']sign ( xt -- )
    c:0key nest$
\    ." sign: " 2dup xtype forth:cr
    c:hash $tmp +cmdbuf
    cmd-resolve>  >r cmdbuf$ drop - r> last-signed 2!  nestsig ;








|




|








624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643

2 Constant fwd# \ maximum 14 bits = 16kB

: nest$ ( -- addr u )  cmdbuf$ neststart# @ safe/string ;

: cmd-resolve> ( -- addr u )
    nest$ over >r dup n>64 cmdtmp$ dup fwd# u> !!stringfit!!
    r> over - swap move
    nest-stack stack> neststart# ! ;

also net2o-base

: +zero16 ( -- ) "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" +cmdbuf ;
: sign[ ( -- ) neststart# @ nest-stack >stack
    string "\x80\x00" +cmdbuf cmdbuf$ nip neststart# ! ;
: nest[ ( -- ) sign[ +zero16 ; \ add space for IV
: ']sign ( xt -- )
    c:0key nest$
\    ." sign: " 2dup xtype forth:cr
    c:hash $tmp +cmdbuf
    cmd-resolve>  >r cmdbuf$ drop - r> last-signed 2!  nestsig ;
︙︙
Changes to net2o-dvcs.fs.
︙︙
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515

    cell +LOOP  log free throw
    dvcs( ." === id>patch ===" cr id>patch# .hash
    ." === id>snap ===" cr id>snap# .hash ) ;
: chat>branches ( o:dvcs -- )
    project:project$ $@ ?msg-log  dvcs:commits @ .chat>branches-loop ;

: >branches ( addr u -- flag )
    $make branches[] deque< ;
User id-check# \ check hash
: id>branches-loop ( addr u -- )
    BEGIN  2dup id-check# #@ d0<> ?EXIT
	s" !" 2over id-check# #!
	2dup id>snap# #@ 2dup d0<> IF  >branches 2drop  EXIT  THEN
	2drop id>patch# #@ 2dup d0<> WHILE
	    2dup hash#128 umin >branches








|








501
502
503
504
505
506
507
508
509
510
511
512
513
514
515

    cell +LOOP  log free throw
    dvcs( ." === id>patch ===" cr id>patch# .hash
    ." === id>snap ===" cr id>snap# .hash ) ;
: chat>branches ( o:dvcs -- )
    project:project$ $@ ?msg-log  dvcs:commits @ .chat>branches-loop ;

: >branches ( addr u -- flag )
    $make branches[] >back ;
User id-check# \ check hash
: id>branches-loop ( addr u -- )
    BEGIN  2dup id-check# #@ d0<> ?EXIT
	s" !" 2over id-check# #!
	2dup id>snap# #@ 2dup d0<> IF  >branches 2drop  EXIT  THEN
	2drop id>patch# #@ 2dup d0<> WHILE
	    2dup hash#128 umin >branches
︙︙
Changes to net2o-msg.fs.
︙︙
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

    IF  save-msgs&  THEN ;

Sema queue-sema

\ peer queue

: peer> ( -- addr / 0 )
    [: peers[] <deque ;] queue-sema c-section ;
: >peer ( addr u -- )
    [: peers[] $+[]! ;] queue-sema c-section ;

\ events

: msg-display ( addr u -- )
    sigpksize# - 2dup + sigpksize# >$  c-state off








|








128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

    IF  save-msgs&  THEN ;

Sema queue-sema

\ peer queue

: peer> ( -- addr / 0 )
    [: peers[] back> ;] queue-sema c-section ;
: >peer ( addr u -- )
    [: peers[] $+[]! ;] queue-sema c-section ;

\ events

: msg-display ( addr u -- )
    sigpksize# - 2dup + sigpksize# >$  c-state off
︙︙
Changes to net2o-tools.fs.
︙︙
260
261
262
263
264
265
266









267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

    count reverse8 r@ $D + c@ reverse8 dst 2 + c! dst $D + c!
    count reverse8 r@ $C + c@ reverse8 dst 3 + c! dst $C + c!
    count reverse8 r@ $B + c@ reverse8 dst 4 + c! dst $B + c!
    count reverse8 r@ $A + c@ reverse8 dst 5 + c! dst $A + c!
    count reverse8 r@ $9 + c@ reverse8 dst 6 + c! dst $9 + c!
    c@    reverse8 r> $8 + c@ reverse8 dst 7 + c! dst $8 + c! ;










\ scoping

Variable scope<>
: scope{ ( "vocabulary" -- scope:addr )
    get-current scope<> >deque also ' execute definitions ;
: }scope ( scope:addr -- )
    previous scope<> deque> set-current ;
: scope: ( "vocabulary" -- scope:addr )
    vocabulary get-current scope<> >deque also lastxt execute definitions ;

: with ( "vocabulary" -- )
    also ' execute postpone >o ; immediate restrict
: endwith ( -- )
    postpone o> previous ; immediate restrict

\ file name sanitizer








>
>
>
>
>
>
>
>
>




|

|

|








260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

    count reverse8 r@ $D + c@ reverse8 dst 2 + c! dst $D + c!
    count reverse8 r@ $C + c@ reverse8 dst 3 + c! dst $C + c!
    count reverse8 r@ $B + c@ reverse8 dst 4 + c! dst $B + c!
    count reverse8 r@ $A + c@ reverse8 dst 5 + c! dst $A + c!
    count reverse8 r@ $9 + c@ reverse8 dst 6 + c! dst $9 + c!
    c@    reverse8 r> $8 + c@ reverse8 dst 7 + c! dst $8 + c! ;

\ aliases for old Gforth (pre 20161202)

[IFDEF] >deque  ' >deque alias >stack [THEN]
[IFDEF] deque>  ' deque> alias stack> [THEN]
[IFDEF] deque<  ' deque< alias >back [THEN]
[IFDEF] <deque  ' <deque alias back> [THEN]
[IFDEF] deque@  ' deque@ alias get-stack [THEN]
[IFDEF] deque!  ' deque! alias set-stack [THEN]

\ scoping

Variable scope<>
: scope{ ( "vocabulary" -- scope:addr )
    get-current scope<> >stack also ' execute definitions ;
: }scope ( scope:addr -- )
    previous scope<> stack> set-current ;
: scope: ( "vocabulary" -- scope:addr )
    vocabulary get-current scope<> >stack also lastxt execute definitions ;

: with ( "vocabulary" -- )
    also ' execute postpone >o ; immediate restrict
: endwith ( -- )
    postpone o> previous ; immediate restrict

\ file name sanitizer
︙︙
Changes to net2o.fs.
︙︙
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

    outbuf free-buf+6 ;

alloc-io

Variable net2o-tasks

: net2o-pass ( params xt n task -- )
    dup net2o-tasks >deque  pass
    ?salt-init off  rng-o off \ make double sure no rng is active
    alloc-io prep-socks catch-loop
    1+ ?dup-IF  free-io 1- ?dup-IF  DoError  THEN
    ELSE  ~~ bflush 0 (bye) ~~  THEN ;
: net2o-task ( params xt n -- task )
    stacksize4 NewTask4 dup >r net2o-pass r> ;

Variable kills
event: ->killed ( -- )  -1 kills +! ;
event: ->kill ( task -- )
    <event ->killed event> 0 (bye) ;
: send-kill ( task -- ) <event up@ elit, ->kill event> ;

#3.000.000.000 2constant kill-timeout# \ 3s

: net2o-kills ( -- )
    net2o-tasks deque@ kills !  net2o-tasks $off
    kills @ 0 ?DO  send-kill  LOOP
    ntime  0 >r \ give time to terminate
    BEGIN  2dup kill-timeout# d+ ntime d- 2dup d0> kills @ and  WHILE
	    stop-dns
	    ntime 2over d- 1000000000 um/mod nip
	    dup r> <> IF  '.' emit  THEN  >r
    REPEAT








|
















|








131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

    outbuf free-buf+6 ;

alloc-io

Variable net2o-tasks

: net2o-pass ( params xt n task -- )
    dup net2o-tasks >stack  pass
    ?salt-init off  rng-o off \ make double sure no rng is active
    alloc-io prep-socks catch-loop
    1+ ?dup-IF  free-io 1- ?dup-IF  DoError  THEN
    ELSE  ~~ bflush 0 (bye) ~~  THEN ;
: net2o-task ( params xt n -- task )
    stacksize4 NewTask4 dup >r net2o-pass r> ;

Variable kills
event: ->killed ( -- )  -1 kills +! ;
event: ->kill ( task -- )
    <event ->killed event> 0 (bye) ;
: send-kill ( task -- ) <event up@ elit, ->kill event> ;

#3.000.000.000 2constant kill-timeout# \ 3s

: net2o-kills ( -- )
    net2o-tasks get-stack kills !  net2o-tasks $off
    kills @ 0 ?DO  send-kill  LOOP
    ntime  0 >r \ give time to terminate
    BEGIN  2dup kill-timeout# d+ ntime d- 2dup d0> kills @ and  WHILE
	    stop-dns
	    ntime 2over d- 1000000000 um/mod nip
	    dup r> <> IF  '.' emit  THEN  >r
    REPEAT
︙︙
Fossil 2.26 [611144ddd9] 2025-05-16 13:52:48