preForth/hi.forth

   1 0 echo !
   2 0 input-echo !
   3
   4 cr .( ⓪ )
   5
   6 : (
   7    ')' parse 2drop ; immediate
   8
   9 : \
  10    source nip >in ! ; immediate
  11
  12 \ cr .( hi - doing some test )
  13 \ t{ 3 4 + -> 7 }t   \ pass
  14 \ t{ 3 -> }t         \ wrong number of results
  15 \ t{ 3 4 + -> 8 }t   \ incorrect result
  16
  17 : AHEAD  ( -- c:orig )
  18     postpone branch  here 0 , ; immediate
  19
  20 : IF ( -- c:orig )
  21     postpone ?branch here 0 , ; immediate
  22
  23 : THEN ( c:orig -- )
  24     here swap ! ; immediate
  25
  26 : ELSE ( c:orig1 -- c:orig2 )
  27     postpone AHEAD  swap  postpone THEN ; immediate
  28
  29 : BEGIN ( -- c:dest )
  30     here ; immediate
  31
  32 : WHILE ( c: orig -- c:dest c:orig )
  33     postpone IF swap ; immediate
  34
  35 : AGAIN ( c:orig -- )
  36     postpone branch , ; immediate
  37
  38 : UNTIL ( c:orig -- )
  39     postpone ?branch , ; immediate
  40
  41 : REPEAT ( c:orig c:dest -- )
  42     postpone AGAIN   postpone THEN ; immediate
  43
  44 \ are these necessary?
  45 \ you can use the phrase  dup x = IF drop  instead of   x case? IF  or  x OF
  46 : case? ( n1 n2 -- true | n1 false )
  47     over = dup IF nip THEN ;
  48
  49 : OF ( n1 n2 -- n1 | )
  50     postpone case?  postpone IF ; immediate
  51
  52 cr .( ① )
  53 cr
  54
  55 : :noname ( -- xt )
  56     new ] ;
  57
  58 : Variable ( <name> )
  59     Create 0 , ;
  60
  61 : Constant ( x <name> -- )
  62     Create , Does> @ ;
  63
  64 0 Constant false
  65 false invert Constant true
  66
  67
  68 : on  ( addr -- ) true  swap ! ;
  69 : off ( addr -- ) false swap ! ;
  70
  71
  72 : fill ( c-addr u x -- )
  73      >r BEGIN ( c-addr u )
  74           dup
  75         WHILE ( c-addr u )
  76            r@ third c!
  77            1 /string
  78         REPEAT ( c-addr u )
  79     2drop r> drop
  80 ;
  81
  82 : erase ( c-addr u -- )  0 fill ;
  83 : blank ( c-addr u -- ) bl fill ;
  84
  85 : 0> ( n -- f )  0 > ;
  86
  87 t{  10 0> -> -1 }t
  88 t{   0 0> ->  0 }t
  89 t{ -10 0> ->  0 }t
  90
  91 : 2>r ( x1 x2 -- r:x1 r:x2 )
  92    swap r> swap >r swap >r >r ;
  93
  94 : 2r> ( r:x1 r:x2 -- x1 x2 )
  95    r>   r> swap r> swap >r  swap ;
  96
  97 : 2r@ ( r:x1 r:x2 -- r:x1 r:x2 x1 x2 )
  98    r>   r> r> 2dup >r >r swap  rot >r ;
  99
 100 : 2>r-test ( x1 x2 -- x1 x2 )  2>r r> r> swap ;
 101 t{ 3 4 2>r-test -> 3 4 }t
 102
 103 : 2r>-test ( x1 x2 -- x1 x2 )  swap >r >r  2r> ;
 104 t{ 3 4 2r>-test -> 3 4 }t
 105
 106 : 2r@-test ( x1 x2 -- x1 x2 )  2>r  2r@  2r> 2drop ;
 107 t{ 3 4 2r@-test -> 3 4 }t
 108
 109
 110 : n>r ( x1 ... xn -- r: xn ... x1 n )
 111    dup                        \  --
 112    BEGIN ( xn ... x1 n n' )
 113       ?dup
 114    WHILE ( xn ... x1 n n' )
 115       rot r> swap >r >r    ( xn ... n n' ) ( R: ... x1 )
 116       1-                   ( xn ... n n' ) ( R: ... x1 )
 117    REPEAT ( n )
 118    r> swap >r >r ;
 119
 120 : nr> ( R: x1 .. xn n -- xn .. x1 n )
 121 \ Pull N items and count off the return stack.
 122    r>  r> swap >r dup
 123    BEGIN
 124       ?dup
 125    WHILE
 126       r> r> swap >r -rot
 127       1-
 128    REPEAT ;
 129
 130 : n>r-test ( x1 x2 -- n x1 x2 )  2 n>r r> r> r> ;
 131 t{ 3 4 n>r-test -> 2 3 4 }t
 132
 133 : nr>-test ( x1 x2 -- x1 x2 n )  >r >r 2 >r  nr> ;
 134 t{ 3 4 nr>-test -> 3 4 2 }t
 135
 136 : 2rot ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
 137     2>r 2swap 2r> 2swap ;
 138
 139 t{ 1 2 3 4 5 6 2rot -> 3 4 5 6 1 2 }t
 140
 141
 142 : lshift ( x u -- ) BEGIN ?dup WHILE swap 2* swap 1-  REPEAT ;
 143
 144 \ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
 145 : u2/ ( x1 -- x2 )
 146    0  8 cells 1-  \ for every bit
 147    BEGIN ( x q n )
 148       ?dup
 149    WHILE  ( x q n )
 150       >r 2*  over 0< IF 1+ THEN  >r 2* r> r> 1-
 151    REPEAT ( x q n )
 152    nip ;
 153
 154 t{ -1 u2/  dup 1+ u< -> -1 }t
 155 t{ -1 u2/  10 +  dup 10 + u< -> -1 }t
 156
 157
 158 : rshift ( x u -- ) BEGIN ?dup WHILE swap u2/ swap 1-  REPEAT ;
 159
 160 : s>d ( n -- d )  dup 0< ;
 161
 162 t{ 1 3 lshift -> 8 }t
 163 \ t{ 48 3 rshift -> 6 }t
 164
 165 : <> ( x1 x2 -- f ) = 0= ;
 166 t{ 3 3 <> -> 0 }t
 167 t{ 'x' 'u' <> -> -1 }t
 168
 169
 170 : pick ( xn ... xi ... x0 i -- xn ... xi ... x0 xi )
 171     1+ cells sp@ + @ ;
 172 t{ 10 20 30 1 pick ->  10 20 30 20 }t
 173
 174 : recursive ( -- )  reveal ; immediate
 175
 176 : roll ( xn-1 ... x0 i -- xn-1 ... xi-1 xi+1 ... x0 xi )
 177     recursive ?dup IF swap >r 1- roll r> swap THEN ;
 178
 179 t{ 10 20 30 1 roll ->  10 30 20 }t
 180
 181 | Variable (to) (to) off
 182
 183 : Value ( x -- )
 184     Create ,
 185     Does>
 186        (to) @ IF ! (to) off ELSE @ THEN ;
 187
 188 : to ( x <name> -- )  (to) on ;
 189
 190 5 Value val
 191 t{ val  42 to val  val -> 5 42 }t
 192
 193
 194 :  within ( test low high -- flag )
 195      over - >r - r>  u<  ;
 196
 197 t{ 2 3 5 within -> false }t
 198 t{ 3 3 5 within -> true }t
 199 t{ 4 3 5 within -> true }t
 200 t{ 5 3 5 within -> false }t
 201 t{ 6 3 5 within -> false }t
 202
 203
 204 : n' parse-name find-name ;
 205
 206
 207 \ cr cr words cr
 208 cr .( ready )
 209 cr .( ② )
 210
 211 \ : test s" xlerb" evaluate ;
 212
 213 : * ( n1 n2 -- )
 214    2dup xor 0< >r abs swap abs um* drop r> IF negate THEN ;
 215
 216 : fac ( n -- ) recursive
 217     dup 0= IF drop 1 exit THEN
 218     dup 1- fac * ;
 219
 220 t{ 6 fac -> 720 }t
 221
 222 : fib ( n1 -- n2 ) recursive
 223     dup 0=  IF exit THEN
 224     dup 1 = IF exit THEN
 225     dup 1- fib  swap 2 - fib + ;
 226
 227 t{ 10 fib -> 55 }t
 228
 229 : sqr ( u -- u^2 )  dup * ;
 230
 231 : u/ ( u1 u2 -- u3 )  >r 0 r> um/mod nip ;
 232
 233 : sqrt ( u^2 -- u )
 234     dup 0= ?exit
 235     dup >r dup
 236     BEGIN ( xi-1 xi )
 237       nip dup
 238       \ x = (x + n//x) // 2
 239       r@ over u/ + u2/ ( xi xi+1 )
 240       2dup over 1+ over = >r = r> or
 241     UNTIL ( xi xi+1 )
 242     drop r> drop ;
 243
 244 t{ 15 sqrt -> 3 }t
 245 t{ 16 sqrt -> 4 }t
 246
 247 : pyth ( a b -- c )
 248     swap sqr  swap sqr  + sqrt ;
 249
 250 t{ 3 4 pyth -> 5 }t
 251 t{ 65535 dup * sqrt -> 65535 }t
 252
 253
 254
 255 \ remove headers from dictionary
 256 | : unlink-header ( addr name -- ) \ 2dup ." unlink " . .
 257      dup >r ( _link ) @ swap !  r> dispose ;
 258
 259 : remove-headers ( -- )
 260    context @ dup @
 261    BEGIN ( addr name )
 262       dup
 263    WHILE ( addr name )
 264       dup headerless? IF over >r unlink-header r> ELSE nip THEN ( addr )
 265       dup @
 266    REPEAT
 267    2drop ;
 268
 269 : clear ( -- )  remove-headers ;
 270
 271 | : hidden-word ." still there - " ;
 272
 273 : visible-word ( -- ) hidden-word hidden-word ;
 274
 275 : save-mem ( c-addr1 u1 -- c-addr2 u2 )
 276     dup >r allocate throw swap over r@ cmove r> ;
 277
 278 : s( ( -- c-addr u )
 279     ')' parse  save-mem ; immediate
 280
 281 cr .( ③ )
 282
 283 \ : Marker ( <name> -- )
 284 \    Create here , hp @ , Does> 2@  here - allot   hp ! ;
 285 \ Cannot access hp  what about dictionary headers?
 286
 287 \ remove-headers
 288
 289 : package ( <name> -- )  parse-name 2drop ;
 290 : private ( -- ) heads off ;
 291 : public ( -- ) heads on ;
 292 : end-package ( -- ) remove-headers ;
 293
 294
 295 package test
 296   : a ." a" ;
 297 private
 298   : b ." b" ;
 299 public
 300   : c a b ." c" ;
 301 end-package
 302
 303 t{ s( abc) s( abc) compare -> 0 }t
 304 t{ s( abc) s( ab)  compare -> 1 }t
 305 t{ s( ab)  s( abc) compare -> -1 }t
 306 t{ s( abc) s( def)  compare -> -1 }t
 307 t{ s( def) s( abc)  compare -> 1 }t
 308
 309 : Defer ( <name> -- )
 310     Create 0 , Does> @ execute ;
 311
 312 Defer %defer  ' %defer >body 2 cells -  @  Constant dodefer
 313               ' %defer >body 1 cells -  @  Constant dodoes
 314
 315
 316 \ highly implementation specific
 317 : backpatch1 ( xt1 xt2 -- ) >body >r
 318     >body 1 cells -  r@ !
 319     [ ' exit ] Literal >body 1 cells - r> cell+ ! ;
 320
 321 : dp! ( addr -- )  here - allot ;
 322
 323 : backpatch ( xt1 xt2 -- )
 324     here >r  >body dp!  compile,  postpone exit  r> dp! ;
 325
 326 : hallo ." original" ;
 327 : moin hallo hallo ;
 328
 329 : abc ." backpatched" ;
 330
 331 ' abc ' hallo backpatch
 332
 333
 334
 335
 336 : FOR ( n -- )
 337     postpone BEGIN
 338     postpone >r ; immediate
 339
 340 : NEXT ( -- )
 341     postpone r>
 342     postpone 1-
 343     postpone dup
 344     postpone 0<
 345     postpone UNTIL
 346     postpone drop ; immediate
 347
 348 : cntdwn 65535 FOR r@ . NEXT ;
 349
 350 : �  sqr ;
 351 : √  sqrt ;
 352
 353 : ⟼  -> ;
 354
 355 : testall ( -- ) \ see if sqrt works for all 32 bit numbers
 356     65535 FOR
 357        t{ r@ ² √  ⟼  r@ }t
 358     NEXT ." ⚑" ;
 359
 360 cr .( ➍ )
 361
 362 Variable Δ
 363
 364 : ❤️ ." love" ;
 365 : ♩ ." pling" ;
 366 : :smile: ." 😀" ;
 367
 368 Variable ∆t
 369
 370 Variable voc-link  0 voc-link !
 371
 372 : Vocabulary ( <name> -- )
 373    wordlist Create here voc-link @ , voc-link ! last @ , ,
 374    Does> 2 cells +  @  >r get-order nip r> swap set-order ;
 375
 376 : .voc ( wid -- )
 377    dup forth-wordlist = IF drop ." Forth " exit THEN
 378    voc-link @
 379    BEGIN ( wid link )
 380      dup
 381    WHILE ( wid link )
 382      2dup  2 cells + @ = IF  nip cell+ @ _name count type space exit THEN
 383      @
 384    REPEAT ( wid 0 )
 385    drop u. ;
 386
 387 ' .voc ' .wordlist backpatch
 388
 389
 390 : recurse ( -- )  last @ _xt @ compile, ; immediate
 391
 392 : cntd ( n -- ) ?dup 0= ?exit dup . 1- recurse '.' emit ;
 393
 394 \ division / /mod  fm/mod sm/rem mod
 395
 396 : s>d ( n -- d )  dup 0< ;
 397
 398 : dnegate ( d1 -- d2 )  ;   \ define w/o carry
 399
 400 : sm/rem ( d1 n1 -- n2 n3 ) ;
 401
 402
 403 t{  10 s>d  3  sm/rem ->   1  3 }t
 404 t{ -10 s>d  3  sm/rem ->  -1 -3 }t
 405 t{  10 s>d -3  sm/rem ->   1 -3 }t
 406 t{ -10 s>d -3  sm/rem ->  -1  3 }t
 407
 408
 409 \ number output:  <# # #s #> sign hold holds base . u. .r u.r
 410
 411 Variable base
 412 Variable hld
 413
 414 : hold ( c -- )   -1 hld +!  hld @ c! ;
 415
 416 \ : holds ( c-addr u -- )  recursive
 417 \    dup 0= IF 2drop exit THEN
 418 \    over c@ >r  1 /string holds  r> hold ;
 419
 420 : holds ( c-addr u -- )
 421    BEGIN dup WHILE 1- 2dup + c@ hold REPEAT 2drop ;
 422
 423 : mu/mod ( d n1 -- rem d.quot )
 424    >r   0 r@  um/mod   r> swap >r um/mod  r> ;
 425
 426 : <# ( -- )  pad hld ! ;
 427
 428 : # ( ud1 -- ud2 )
 429      base @ mu/mod  rot 9 over < IF [ 'A' '9' 1+ - ] Literal + THEN '0' + hold ;
 430
 431 : #s ( ud1 -- d.0 )  BEGIN #  2dup or 0= UNTIL ;
 432
 433 : #> ( ud -- c-addr u )  2drop hld @ pad over - ;
 434
 435 : sign ( n -- )  0< IF '-' hold THEN ;
 436
 437 : decimal ( -- ) 10 base ! ; decimal
 438 : hex     ( -- ) 16 base ! ;
 439
 440 | : (.) ( n -- ) dup abs 0 <# #s rot sign #> ;
 441 : dot ( n -- )  (.) type space ; ' dot ' . backpatch
 442 : .r ( n l -- )  >r (.) r> over - 0 max spaces type ;
 443
 444 | : (u.) ( u -- ) 0 <# #s #> ;
 445 : u. ( u -- ) (u.) type space ;
 446 : u.r ( u l -- )  >r (u.) r> over - 0 max spaces type ;
 447
 448 : at-xy ( u1 u2 -- ) \ col row
 449     base @ >r decimal
 450     esc ." [" 1+  0 u.r ." ;" 1+ 0 u.r ." H"
 451     r> base ! ;
 452
 453 \ : at? CSI 6n
 454
 455 : clreol ( -- )
 456     esc ." [K" ;
 457
 458 : scroll-up ( -- )
 459     esc ." [S" ;
 460
 461 : white ( -- )  esc ." [37m" ;
 462 : blue-bg ( -- )  esc ." [44m" ;
 463
 464 : save-cursor-position ( -- ) 27 emit '7' emit ;
 465 : restore-cursor-position  ( -- ) 27 emit '8' emit ;
 466
 467 0 Value status-line
 468 132 Value terminal-width
 469
 470 : show-status ( -- )
 471    status-line IF scroll-up THEN
 472    save-cursor-position blue-bg white
 473    base @ >r decimal
 474    0 status-line 1 max at-xy  ( clreol ) terminal-width spaces
 475    0 status-line 1 max at-xy
 476      ."  seedForth 😉     "
 477      ." | free: " unused u.
 478      ." | order: " order
 479      ." | base: "  r@ .
 480      ." | " depth 0= IF ." ∅" ELSE .s THEN
 481    r> base !
 482    normal restore-cursor-position
 483    status-line 0= ?exit
 484    0 status-line 1 - at-xy clreol
 485    0 status-line 2 - at-xy
 486 ;
 487
 488 : +status ( -- ) [ ' show-status ] Literal  [ ' .status >body ] Literal ! ;
 489 : -status ( -- ) [ ' noop ] Literal  [ ' .status >body ] Literal ! ;
 490
 491
 492 only Forth also definitions
 493 Vocabulary root
 494
 495 : only ( -- ) only root ;
 496
 497 root definitions
 498
 499 : order order ;
 500 : definitions definitions ;
 501 : words words ;
 502 : Forth Forth ;
 503 : only only ;
 504 : also also ;
 505 : bye bye ;
 506
 507 only Forth also definitions
 508
 509 : mod ( u1 u2 -- u3 ) 0 swap um/mod drop ;
 510
 511 : prime? ( u -- f )
 512     dup 2 = IF drop true exit THEN
 513     dup 2 mod 0= IF drop false exit THEN
 514     3 BEGIN ( u i )
 515         2dup dup * < 0=
 516       WHILE ( u i )
 517         2dup mod  0= IF 2drop false exit THEN
 518         2+
 519       REPEAT ( u i )
 520       2drop true
 521 ;
 522
 523 : th.prime ( u -- )
 524     1 BEGIN over WHILE 1+ dup prime? IF swap 1- swap THEN REPEAT nip ;
 525
 526 cr cr cr .( The ) 10001 dup . .( st prime is ) th.prime .
 527
 528
 529 \ cooperative multi tasker
 530 \ -------------------------
 531
 532 Variable up  \ user pointer
 533
 534 : up@ ( -- x ) up @ ;
 535 : up! ( x -- ) up ! ;
 536
 537 : User ( x -- )
 538     Create , Does> @ up@ + ;
 539
 540 : his ( task addr -- ) up@ - + ;
 541
 542 0
 543 1 cells over + swap User task-state
 544 1 cells over + swap User task-link
 545 1 cells over + swap User error#
 546 1 cells over + swap User sp-save
 547 1 cells over + swap User rp-save
 548 1 cells over + swap User frame-save
 549
 550 Constant task-size
 551
 552 : pause ( -- )
 553     rp@  rp-save !  sp@ sp-save ! frame @ frame-save !
 554     BEGIN task-link @ up! task-state @ UNTIL
 555     sp-save @ sp!  rp-save @ rp! frame-save @  frame ! ;
 556
 557 Create operator
 558    true ,      \ task-state
 559    operator ,  \ task-link to itself
 560    0 ,         \ error#
 561    0 ,         \ sp-save
 562    0 ,         \ rp-save
 563
 564 operator up!
 565
 566
 567 : task ( stacksize rstacksize -- tid )
 568     here >r
 569     0 , ( task-state )
 570     task-link @ , r@ task-link !
 571     0 , ( error# )
 572     over  here + 2 cells + , ( sp-save )
 573     + dup here +   cell+ ,   ( rp-save )
 574     allot              \ allocate stack and return stack
 575     r> ;
 576
 577 : wake ( tid -- )   task-state his on ;
 578 : sleep ( tid -- )  task-state his off ;
 579 : stop ( -- ) up@ sleep pause ;
 580
 581 : task-push ( x tid -- ) \ push x on tids stack
 582    sp-save his  dup >r @  1 cells -  dup r> !  !
 583 ;
 584
 585 : task-rpush ( x tid -- ) \ push x on tids return-stack
 586     rp-save his  dup >r @  1 cells -  dup r> !  !
 587 ;
 588
 589 | : (activate) ( xt -- )
 590     catch  error# !  stop ;
 591
 592 : activate ( xt tid -- )
 593     \ put xt on stack of tid
 594     dup >r  task-push
 595     \ put (activate)'s body on return stack
 596     [ ' (activate) >body ] Literal  r@ task-rpush
 597     r> wake
 598 ;
 599
 600 : ms ( u -- )  1000 * usleep ;
 601
 602 100 cells 100 cells  task Constant t1
 603
 604 Variable counter  0 counter !
 605 : do-counter ( -- )
 606    BEGIN  1 counter +!  pause  AGAIN ;
 607
 608 ' do-counter  t1 activate
 609
 610 100 cells 100 cells task Constant counter-display
 611
 612 : ctr ( -- x ) counter @ 8 rshift ;
 613
 614 : .emoji ( n -- )
 615     0 OF ." 😀" exit THEN
 616     1 OF ." 😃" exit THEN
 617     2 OF ." 😄" exit THEN
 618     3 OF ." 😆" exit THEN
 619     4 OF ." ☺️" exit THEN
 620     5 OF ." 😊" exit THEN
 621     6 OF ." 🙂" exit THEN
 622     7 OF ." 😉" exit THEN ;
 623
 624 : .counter ( -- )
 625     BEGIN
 626        ctr
 627        BEGIN pause ctr  over - UNTIL drop
 628        save-cursor-position blue reverse
 629        11 status-line dup 1 = IF 1- THEN at-xy
 630        ctr 3 rshift 7 and .emoji
 631        14 status-line dup 1 = IF 1- THEN at-xy
 632        ctr 0 999 um/mod drop 3 u.r
 633        normal restore-cursor-position
 634     AGAIN ;
 635 ' .counter counter-display activate
 636
 637 1000 Value cycle-time
 638
 639 : multikey ( -- c) BEGIN pause key? 0= WHILE  cycle-time usleep  REPEAT key ;
 640
 641 : multi ( -- ) [ ' multikey ] Literal [ ' getkey >body ] Literal ! ;
 642 : single ( -- ) [ ' key ] Literal [ ' getkey >body ] Literal ! ;
 643
 644 : stars ( n -- )  ?dup IF  1- FOR '*' emit NEXT  THEN ;
 645
 646 0 to status-line
 647 cr .( Adjust your terminal to have ) status-line 1+ . .( lines.)
 648
 649 -77 Constant UTF-8-err
 650
 651 128 Constant max-single-byte
 652
 653 : u8@+ ( u8addr -- u8addr' u )
 654     count  dup max-single-byte u< ?exit  \ special case ASCII
 655     dup 194 u< IF  UTF-8-err throw  THEN  \ malformed character
 656     127 and  64 >r
 657     BEGIN  dup r@ and  WHILE  r@ xor
 658       6 lshift r> 5 lshift >r >r count
 659       dup 192 and 128 <> IF   UTF-8-err throw  THEN
 660       63 and r> or
 661     REPEAT  r> drop ;
 662
 663 : u8!+ ( u u8addr -- u8addr' )
 664     over max-single-byte u< IF  swap over c! 1+  exit  THEN \ special case ASCII
 665     >r 0 swap  63
 666     BEGIN  2dup swap u<  WHILE
 667       u2/ >r  dup 63 and 128 or swap 6 rshift r>
 668     REPEAT  127 xor 2* or  r>
 669     BEGIN   over 128 u< 0= WHILE  swap over c! 1+  REPEAT  nip ;
 670
 671 cr s( Δ) 2dup type .(  has codepoint ) drop  u8@+ . drop
 672
 673 cr 916 pad u8!+ pad swap over - type
 674
 675 t{ s( Δ) drop u8@+ nip -> 916 }t
 676 t{ 916 pad u8!+   pad -   pad c@  pad 1+ c@ -> 2 206 148 }t
 677
 678 +status
 679
 680 | : ?:     dup 4 u.r ." :" ;
 681 | : @?     dup @ 6 u.r ;
 682 | : c?     dup c@ 6 u.r ;
 683 | : ?:@?   ?: 4 spaces @? ;
 684 | : >#     spaces u. ;
 685
 686 : s ( adr - adr+1 ) \ string
 687     ?: 4 spaces c? 2 spaces  dup 1+ over c@ type  dup c@ + 1+ ;
 688
 689 : .name ( name -- ) ?dup IF count type exit THEN ." ???" ;
 690
 691 : n ( adr - adr' )  \ name
 692      ?:@? 2 spaces  dup @ addr>name .name cell+ ;
 693
 694 : d ( adr n - adr+n )  \ dump
 695      2dup swap ?:  swap  FOR c? 1+ NEXT  2 spaces  -rot type ;
 696
 697 : l ( adr - adr' )  ?:   dup @ 12 ># cell+ ;  \ cell
 698 : c ( adr - adr+1)  1 d ;                     \ character
 699 : b ( adr - adr')   ?:@? dup @  2 ># cell+ ;  \ branch, could be relative
 700
 701 cr .( Interactive decompiler: User single letter commands n d l c b s ) cr
 702
 703 \ Dump utility
 704
 705 | : .hexdigit ( x -- )
 706      dup 10 < IF '0' + ELSE  10 - 'A' + THEN emit ;
 707
 708 | : .hex ( x -- )
 709      dup 240 and  4 rshift .hexdigit   15 and .hexdigit ;
 710
 711 | : .addr ( x -- )
 712      ?dup 0= ?exit dup 8 rshift  recurse  .hex ;
 713
 714 | : b/line ( -- x )
 715      16 ;
 716
 717 | : .h ( addr len -- )
 718    b/line min dup >r
 719    BEGIN \ ( addr len )
 720      dup
 721    WHILE \ ( addr len )
 722      over c@ .hex space  1 /string
 723    REPEAT 2drop
 724    b/line r> - 3 * spaces ;
 725
 726 | : .a ( addr1 len1 -- )
 727      b/line min
 728      BEGIN \ ( addr len )
 729        dup
 730      WHILE
 731        over c@ dup 32 < IF drop '.' THEN emit
 732        1 /string
 733      REPEAT 2drop ;
 734
 735 | : dump-line ( addr len1 -- addr len2 )
 736      over .addr ':' emit space   2dup .h space space  2dup .a
 737      dup  b/line  min /string
 738 ;
 739
 740
 741 : dump ( addr len -- )
 742    BEGIN
 743      dup
 744    WHILE \ ( addr len )
 745      cr dump-line
 746    REPEAT 2drop ;
 747
 748
 749
 750
 751
 752
 753 echo on cr cr .( Welcome! ) input-echo on