preForth/hi.forth

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