debugging.fs 6.78 KB
Newer Older
1 2
\ debugging aids

3
false [IF]
bernd's avatar
bernd committed
4 5 6 7
    : debug: ( -- )  Create immediate false ,
      DOES>
	@ IF  ['] noop assert-canary
	ELSE  postpone (  THEN ;
bernd's avatar
bernd committed
8
    : )else(  ]] ) ( [[ ; immediate \ )
9 10
[THEN]

11 12
: nodebug: ['] ( Alias immediate ;
	
bernd's avatar
bernd committed
13 14
: hex[ ]] [: [[ ; immediate
: ]hex ]] ;] $10 base-execute [[ ; immediate
15 16
: x~~ ]] hex[ ~~ ]hex [[ ; immediate

17 18
: xtype ( addr u -- )  hex[
    bounds ?DO  I c@ 0 <# # # #> type  LOOP  ]hex ;
bernd's avatar
bernd committed
19 20
: .nnb ( addr n -- )  xtype ;
: .64b ( addr -- ) 64 .nnb ;
21 22 23 24 25 26 27 28 29 30 31 32 33

: (digits>$) ( addr u -- addr' u' ) save-mem
    >r dup dup r> bounds ?DO
	I 2 s>number drop over c! char+ 
    2 +LOOP  over - ;

: hex>$ ( addr u -- addr' u' )
    ['] (digits>$) $10 base-execute ;

: x" ( "hexstring" -- addr u )
    '"' parse hex>$ ;
comp: execute postpone SLiteral ;

bernd's avatar
bernd committed
34
\ base64 output (not the usual base64, suitable as filenames)
bernd's avatar
bernd committed
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

: .b64 ( n -- n' ) dup >r 6 rshift r> $3F and
    dup #10 u< IF  '0' + emit  EXIT  THEN  #10 -
    dup #26 u< IF  'A' + emit  EXIT  THEN  #26 -
    dup #26 u< IF  'a' + emit  EXIT  THEN  #26 -
    IF  '_'  ELSE  '-'  THEN  emit ;
: .1base64 ( addr -- )
    c@ .b64 .b64 drop ;
: .2base64 ( addr -- )
    le-uw@ .b64 .b64 .b64 drop ;
: .3base64 ( addr -- )
    le-ul@ $FFFFFF and .b64 .b64 .b64 .b64 drop ;
Create .base64s ' drop , ' .1base64 , ' .2base64 , ' .3base64 ,
: 64type ( addr u -- )
    bounds ?DO  I I' over - 3 umin cells .base64s + perform  3 +LOOP ;

: b64digit ( char -- n )
    '0' - dup #09 u<= ?EXIT
    [ 'A' '9' - 1- ]L - dup #36 u<= ?EXIT
    dup #40 = IF  drop #63  EXIT  THEN
    [ 'a' 'Z' - 1- ]L - dup #62 u<= ?EXIT
    drop #62 ;
    
: base64>n ( addr u -- n )  0. 2swap bounds +DO
	I c@ b64digit over lshift rot or swap 6 +
    LOOP  drop ;
: base64>$ ( addr u -- addr' u' ) save-mem >r dup dup r@ bounds ?DO
	I I' over - 4 umin base64>n over le-l! 3 +
    4 +LOOP  drop r> 3 4 */ ;

: 64" ( "base64string" -- addr u )
    '"' parse base64>$ ;
comp: execute postpone SLiteral ;

bernd's avatar
bernd committed
69
\ base85 output (derived from RFC 1924, suitable as file name)
70

71
85 buffer: 85>chars
bernd's avatar
bernd committed
72
s" 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#$%&()*+-;<=>?@^_`{|}~"
73 74 75
85>chars swap move
$80 buffer: chars>85
85 0 [DO] [I] dup 85>chars + c@ chars>85 + c! [LOOP]
bernd's avatar
bernd committed
76

77
: .b85 ( n -- n' ) 85 /mod swap 85>chars + c@ emit ;
78 79 80 81 82 83 84 85
: .1base85 ( addr -- ) c@ .b85 .b85 drop ;
: .2base85 ( addr -- ) le-uw@ .b85 .b85 .b85 drop ;
: .3base85 ( addr -- ) le-ul@ $FFFFFF and .b85 .b85 .b85 .b85 drop ;
: .4base85 ( addr -- ) le-ul@ .b85 .b85 .b85 .b85 .b85 drop ;
Create .base85s ' drop , ' .1base85 , ' .2base85 , ' .3base85 , ' .4base85 ,
: 85type ( addr u -- )
    bounds ?DO  I I' over - 4 umin cells .base85s + perform  4 +LOOP ;

86
: b85digit ( char -- n ) $7F umin chars>85 + c@ ;
87 88
    
: base85>n ( addr u -- n )  0 1 2swap bounds +DO
bernd's avatar
bernd committed
89
	I c@ b85digit over * rot + swap 85 *
90 91 92 93 94 95 96 97 98
    LOOP  drop ;
: base85>$ ( addr u -- addr' u' ) save-mem >r dup dup r@ bounds ?DO
	I I' over - 5 umin base85>n over le-l! 4 +
    5 +LOOP  drop r> 4 5 */ ;

: 85" ( "base85string" -- addr u )
    '"' parse base85>$ ;
comp: execute postpone SLiteral ;

99 100 101 102 103 104 105 106
\ debugging switches

debug: timing(
debug: bursts(
debug: resend(
debug: track(
debug: data(
debug: cmd(
107
debug: cmd0(
108 109 110 111 112 113
debug: send(
debug: firstack(
debug: msg(
debug: stat(
debug: timeout(
debug: ack(
114
debug: crypt(
bernd's avatar
bernd committed
115
debug: noens(
116
debug: key(
117
debug: genkey( \ See generated keys - never let this go to a log file!
bernd's avatar
bernd committed
118 119
debug: cookie( 
debug: cookies( \ dump all cookies on rewinding
120 121
debug: delay( \ used to add delays at performance critical places
debug: tag(
bernd's avatar
bernd committed
122
debug: flush(
bernd's avatar
bernd committed
123 124
debug: flush1(
debug: flush2(
bernd's avatar
bernd committed
125
debug: flush3(
bernd's avatar
bernd committed
126
debug: waitkey(
127
debug: address(
bernd's avatar
bernd committed
128
debug: dump(
bernd's avatar
bernd committed
129
debug: trace(
bernd's avatar
bernd committed
130
debug: header(
bernd's avatar
bernd committed
131
debug: sender( \ extra sender task
bernd's avatar
bernd committed
132
debug: dht( \ debugging for dht functions
bernd's avatar
bernd committed
133
debug: hash( \ dht hasing function debug
bernd's avatar
bernd committed
134
debug: file( \ file read/write debugging
135
debug: bg( \ started in background mode
bernd's avatar
bernd committed
136
debug: nat( \ NAT traversal stuff
bernd's avatar
bernd committed
137
debug: route( \ do routing
bernd's avatar
bernd committed
138 139
debug: noipv6( \ use only ipv4 for routing
debug: noipv4( \ use only ipv6 for routing
bernd's avatar
bernd committed
140
debug: request( \ track requests
bernd's avatar
bernd committed
141
debug: beacon( \ debug sending beacons
bernd's avatar
bernd committed
142
debug: replace-beacon( \ reply to every beacon
bernd's avatar
bernd committed
143
debug: kalloc( \ secure allocate
bernd's avatar
bernd committed
144
debug: invalid( \ print invalid packets
bernd's avatar
bernd committed
145
debug: regen( \ regenerate keys
146

bernd's avatar
bernd committed
147
-db profile( \ )
bernd's avatar
bernd committed
148

bernd's avatar
bernd committed
149 150 151 152
\ key debugging task

: toggle ( addr -- )  dup @ 0= swap ! ;

bernd's avatar
bernd committed
153 154 155
0 Value debug-task
: new-debug-task ( -- ) debug-task ?EXIT
    stacksize4 NewTask4 dup to debug-task activate
bernd's avatar
bernd committed
156 157
    BEGIN  case key
	    'c' of  ['] cmd( >body toggle  endof
158
	    'm' of  ['] msg( >body toggle  endof
159 160
	    'r' of  ['] resend( >body toggle  endof
	    'f' of  ['] file( >body toggle  endof
bernd's avatar
bernd committed
161
	    't' of  ['] timeout( >body toggle  endof
bernd's avatar
bernd committed
162 163 164
	endcase
    AGAIN ;

bernd's avatar
bernd committed
165 166
\ timing ticks

bernd's avatar
bernd committed
167 168
64Variable tick-adjust
: ticks ( -- u )  ntime d>64 tick-adjust 64@ 64+ ;
bernd's avatar
bernd committed
169

bernd's avatar
bernd committed
170 171 172
: ticks-u ( -- u )  ticks 64>n ;

false [IF]
173 174
    ' noop alias init-timer
    ' noop alias .times
bernd's avatar
bernd committed
175
    : timer: ['] noop alias immediate ;
176 177
[THEN]

bernd's avatar
bernd committed
178 179 180 181 182 183
require date.fs
1970 1 1 ymd2day Constant unix-day0

: fsplit ( r -- r n )  fdup floor fdup f>s f- ;

: .ticks ( ticks -- )
bernd's avatar
bernd committed
184 185
    64dup 64-0= IF  ." never" 64drop EXIT  THEN
    64dup -1 n>64 64= IF  ." forever" 64drop EXIT  THEN
bernd's avatar
bernd committed
186 187 188 189 190
    64>f 1e-9 f* 86400e f/ fsplit unix-day0 + day2ymd
    rot 0 .r '-' emit swap 0 .r '-' emit 0 .r 'T' emit
    24e f* fsplit 0 .r ':' emit 60e f* fsplit 0 .r ':' emit
    60e f* fdup 10e f< IF '0' emit 5  ELSE  6  THEN  3 3 f.rdp 'Z' emit ;

bernd's avatar
bernd committed
191 192 193 194 195 196 197 198 199 200
timer: +file
timer: +send-cmd
timer: +sendX2
timer: +sendX
timer: +chunk
timer: +desta
timer: +inmove
timer: +next
timer: +reset
timer: +event
bernd's avatar
bernd committed
201
timer: +calc
bernd's avatar
bernd committed
202
timer: +cryptsu
bernd's avatar
bernd committed
203 204 205 206
timer: +enc
timer: +rec
timer: +send
timer: +wait
bernd's avatar
bernd committed
207
timer: +cmd
bernd's avatar
bernd committed
208 209
timer: +dest
timer: +ack
bernd's avatar
bernd committed
210

bernd's avatar
bernd committed
211 212
\ buffered typing

213
Ustack b$
bernd's avatar
bernd committed
214 215 216 217 218

: btype  b$ $+! ;
: bemit  b$ c$+! ;
: bcr    #lf bemit b$ $@ (type) b$ $off ;

bernd's avatar
bernd committed
219 220
' btype ' bemit ' bcr ' form output: b-out
\ ' noop alias b-out
bernd's avatar
bernd committed
221

bernd's avatar
bernd committed
222 223 224
\ misc

: etype ( addr u -- ) >stderr type ;
bernd's avatar
bernd committed
225 226
: $err ( xt -- )  $tmp stderr write-file throw ;
\ : $err ( xt -- ) execute ;
bernd's avatar
bernd committed
227

bernd's avatar
bernd committed
228 229 230 231
\ extra hints for last word executed

: ?int ( throw-code -- throw-code )  dup -28 = IF  bye  THEN ;

232
: m: : ;
bernd's avatar
bernd committed
233
false [IF]
234 235 236 237 238 239 240
    User last-exe-xt
    : .exe ( -- ) last-exe-xt @ .name ;
    : : ( "name" -- colon-sys )
	: lastxt ]]L last-exe-xt ! [[ ;
[ELSE]
    : .exe ;
[THEN]
bernd's avatar
bernd committed
241

bernd's avatar
bernd committed
242
\ more phony throw stuff, only for debugging engine
243

bernd's avatar
bernd committed
244
debugging-method [IF]
245 246 247 248 249 250 251
:noname  ." Store backtrace..." cr defers store-backtrace
    dobacktrace ; is store-backtrace

:noname  ?dup-IF  ." Throw directly" cr dobacktrace
	defers throw  THEN ; is throw
[THEN]

bernd's avatar
bernd committed
252 253
\ Emacs fontlock mode: Highlight more stuff

254 255 256 257
0 [IF]
Local Variables:
forth-local-words:
    (
bernd's avatar
bernd committed
258
     (("debug:" "timer:")
bernd's avatar
bernd committed
259
      non-immediate (font-lock-type-face . 2)
260 261 262
      "[ \t\n]" t name (font-lock-variable-name-face . 3))
     ("[a-z]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
bernd's avatar
bernd committed
263 264
     (("[:") definition-starter (font-lock-keyword-face . 1))
     ((";]") definition-ender (font-lock-keyword-face . 1))
265 266 267
    )
End:
[THEN]