\ templates for tests via mouse cut+paste

\ --------------------------------------------------------------------------------------------------------------------
\ kbd ( note which chars require quoting or to be escaped):

f8 order cr hex "' .s hidden idx>xec 4th>abs (ok) !" cr also linux also editor also testvoc \
also fig also forth also cr order cr cr vocs;n=$?;[ "$n" == "0" ]||{ report -s $n;echo $n; }

./f8 "' .s idx>xec 4th>abs (ok) !" c0 @ 10 0 cr hex .s cr ] do i . i 0 do i j \* \#. loop cr \
[ hex state @ u. cr .s cr ] loop \$12345678 drop 0x90abcdef drop bel dup c-here cr .s cr \
[ over- .s dump cr 6 + \#dcm cr .s .\( alle meine entchen... \) .s cr .s 2>&1 |tee t

\ stderr to file, for debug output
f8 hex "' .s also hidden idx>xec 4th>abs (ok) !" .s cr also linux also editor also 
testvoc also forth also order words 2>t;n=$?;[ "$n" == "0" ]||{ report -s $n;echo $n; }

\ short start
./f8 "'" .s hidden idx\>xec 4th\>abs \(ok\) rvoc \!

\ --------------------------------------------------------------------------------------------------------------------
\ terminal colours
pad2 count 255 0 do 255 0 do 255 0 do i j 2 ni 7 set-palette esc? if reset-palette quit endif loop loop loop

\ --------------------------------------------------------------------------------------------------------------------
\ sys_select

4. sleep pad 100 erase 10 pad 20 + ! pad 20 + 4th>abs pad 8+ ! pad 12 + 4th>abs dup 4- dup 4- dup 4- 2 sp@ #142 syscall
sp> hex pad 100 erase pad 20 + on pad 30 #32 * 0 do dup i btst if i . key drop endif loop

\ --------------------------------------------------------------------------------------------------------------------
\ vt

sp> forget keys : keys key #27 over- if emit exit endif begin ?key -dup sdrop while emit repeat ;
max-xy 2/ swap 2/ swap cur! at-xy cur! 40 1 at-xy xy #. #. ."  <- hier " cur@ ." -> dorth "
forget t : t pad $200 2dup blanks $120    do i . i pad w! pad 4 0 write-file i #16 mod 0= -cr 2drop loop cr ;
   
\ --------------------------------------------------------------------------------------------------------------------
\ rational numbers, runtime test
!timing   5 0 do   1 2 3 4 5 6 7  8  forth forth  ['] noop     (timing) .timing sp> loop cr

\ --------------------------------------------------------------------------------------------------------------------
\ locals, recursion

[s] : kk 2468 local: haha 369c haha - to haha haha . -1234 +to haha haha [ lp ? s0 ? (locn) ? (locb) ? cr [s] cr ] . ;
: ha locals| drei zwei eins | eins zwei drei .s to eins to drei to zwei eins zwei drei -1 +to eins eins 0> 0= -exit recurse ;
: ho locals| eins zwei drei | eins . zwei . drei . eins zwei + +to drei drei . cr ;
: he local: eins s0 u? -1 +to eins eins . eins 0< -exit eins recurse eins 0= -cr eins . s0 u? ;
: hi local: eins s0 u? -1 +to eins eins 0> if eins recurse else eins 0= -cr eins . s0 u? endif ;
: fa local: nn nn 1 > if nn 1- recurse else 1 endif nn * ;
: fo local: nn nn nn 1 > if 1- recurse else drop 1 cr endif nn * ;
: fe locals| n1 n2 n3 n4 |
   n1 . n2 . n3 . n4 . 1 +to n1 2 +to n2 3 +to n3 n1 n2 n3 + + +to n4 n4 1000 < if n1 n2 n3 n4 recurse endif n1 n2 n3 n4 ;
: fi locals| eins zwei |  case eins of ." eins" endof zwei of ." zwei" endof default . endcase .s cr .rs cr ;
: nf locals| n1 | n1 . n1 1 >  if n1 1- s0 u? cr  recurse n1 endif loc-ptr n1 dup u. u? s0 u? cr ;
: qq locals| a1 a2 | a1 a2 - if a1 a2 > +to a1 a1 a2 recurse ." R:" a1 . a2 . cr endif ." E:" a1 . a2 . cr ;

\ specified size
: t4 s0 @ >r { 4: vier 0: null n1 n2 n3 n4 } 
  loc-ptr vier loc-ptr null loc-ptr n1 loc-ptr n2 loc-ptr n3 loc-ptr n4 u? u? u? u? 
  22 dump ." NULL" cr 22 dump ." VIER" cr r> 44 dump ." S0" cr ;
: t1 s0 @ >r { 4: vier | n1 n2 n3 n4 } vier loc-ptr 4 4@ uq. n1 n2 n3 n4 .  . . .  r> 44 dump ;

\ --------------------------------------------------------------------------------------------------------------------
\ deferred, sort, words

' dfdt >data 11 dump defer otto rdump ' bel is otto rdump ' bel is dfdt rdump ' otto deferred? rdump

: pp .s cr u< ; : cc $1000 0 do tick 2/ xor pad i 3 * + xor! loop pad $1000 4/ ; ' pp also util is precedes
: pp esc? if quit endif u< .s cr ; 
: cc $40   0 do tick 2/ xor pad i 3 * + xor! loop pad $10    ; ti-cal drop also util 
: h cc tick 2>r sorted u< tick 2r> d- cr pad $40   bounds do $20 0 do i j + u? 4 +loop cr $20 +loop cr ti-cal dfrac. cr ;

0 context @ wid>top begin  dup @ while dup @ - swap 1+ swap repeat
: cc context @ 0 >r begin 1 r+! dup @ - dup @ 0= until drop r> ;

defer (t) defer (w) s" *" dup stg s ' s is (t)
	: (r) lfa>nfa count (t) search -rot 2drop ; ' (r) is (w)
	: (s) begin dup 0= -exit dup (w) -exit dup @ - dup @ 0= until ;
	selected (s9 words
	"?   ' s >body 5 + c! selected (s) words
			
\ --------------------------------------------------------------------------------------------------------------------
\ ans compliance, benchmark

include 4th/util.f8 include 4th/4/core.f8
include 4/bench.f8 include 4/bm.f8 include 4/tt.f8

include 4th/util.f8 include 4th/4/tester.f8 include 4th/4/core.f8 include 4th/4/bench.4th include 4th/4/tt.fs

\ --------------------------------------------------------------------------------------------------------------------
\ ans LEAVE
ans ans  : t1 100 0 do i 50 > if cr leave endif ." :" i . loop cr ;
forth    : t2 100 0 do i 50 > if cr leave endif ." :" i . loop cr ;
\ --------------------------------------------------------------------------------------------------------------------
\ multi-praecision

fig tools
-1 dup 2dup pad 4! pad 0d ]] .rs cr m>r .rs cr r> 4th>abs u. r> 4th>abs u. r> 4th>abs u. r> 4th>abs u. cr .rs rp! [[
-1 dup 2dup pad 4! pad 0d over 40 dump ]] 2dup .rs .s cr m>r .rs .s cr swap 20 + swap r>m .rs .s cr rdump rp! [[
-0 1+ -1 -0 2dup 3 pick 3 pick ]] .rs .s cr 6 n>r .rs .s cr 6 nr> u. u. u. u. u. u. .rs .s cr rp! [[

\ div-exception signal handler
: p 3dup p1 . . tab p2 . . ; 	10. 7 p cr -10. 7 p cr -10. -7 p cr 10. -7 p cr 0. 0 p cr -10. 0 p cr 10. 0 p cr
]] 10. 10000 0 tick 2>r do i i 2over p1 3drop loop tick 2r> d- d. 10000 0 tick 2>r do i i 2over p2 3drop loop tick 2r> d- d. sp> [[
10. 7 fm/mod . 1 . . 3 . cr  -10. 7 fm/mod . -2 . . 4 . cr 10. -7 fm/mod . -2 . . -4 . cr -10. -7 fm/mod . 1 . . -3 . cr
20. 7 sm/rem . 2 . . 6 . cr  -20. 7 sm/rem . -2 . . -6 . cr 20. -7 sm/rem . -2 . . 6 . cr -20. -7 sm/rem . 2 . . -6 . cr
sp> 1A2B3C4F 4D5E6F10 90A0B0 C0D0E0F0 10203040 50607080 depth dup 1+ ndup .s cr 8 nlshift .s cr  20 0 do sdrop 8 nlshift .s cr loop
sp> 3456789E 9ABCDE20 1214160 81A1C1E0 20406081 A0C0E100 6 1 nlshift ]] tick 2>r 1000 0 do sdrop 1- 1 nlshift loop tick 2r> d- [[

\ --------------------------------------------------------------------------------------------------------------------
\ loop

10   0    begin   dup . 2dup + >r 1+ 2dup + r> xor 2 pick >     until 2drop
10   0    begin   dup . 2dup + >r 1+ 2dup + r> xor 2 pick dup 0> if > else < endif until
  
\ --------------------------------------------------------------------------------------------------------------------
\ vocabularies, linkage to ram, definig words

fig sp! s" bye" over + off 1- ]] tick 2>r 10000 0 do dup find 2drop loop tick 2r> d- decimal d. hex [[

d0 @ here 4+ over- dump ' testvoc idx>lfa lfa>ifa 40 tdump ' root idx>lfa lfa>ifa ' forth idx>lfa lfa>ifa over- tdump
d0 @ here 4+ over- dump ' testvoc idx>lfa dup lfa>ifa 40 tdump lfa>wid wid>top d0 @ dup 40 tdump ifa>lfa dup lfa>wid dup wid>top 
(intermediately: ]] fld dup @ - voc-link @ swap minus voc-link + voc-link ! vocs voc-link ! [[ )
]] create EMIL bel c-here u. here u. cpl; [[ also assembler <ret> 1, previous

: EMIL bel c0 @ c-here over- 10 + dump ;
create OTTO bel c-here u. here u. smudge ' EMIL idx>xec c-here over- tdump
: HA ." H1" create c-here , ." H2" does> ." H3" ; : HO ." O1" HA here , ." O2" does> ." O3" ;
: hs 10 0 do i dup 5 <  if i .   else i 5 = -leave endif . loop bel ;
: HA ." H:" create c-here , ." H," does> @+ ." H>" ; : HO HA here , ." O," does> dup u. ." O>" ; ha hu cr ho he cr see ha cr see he
: h c-here u. ; c-here 90 dump : HA create a , ." A,"h does> @+ ." A>"; : HO h ." O:"HA f , ." O,"h does> ." O>"dup u. ; rdump
: h here u. c-here u. ; c-here 90 dump : HA create a , ." A" h does> @+ ; : HO h ." O:" HA f , ." O," h does> ." O>" dup u. ; rdump

-find meier sdrop 0= if [ 2variable meier ] 1234567890abcdef. meier 2! endif meier 2@ d. 
-find emil sdrop 0= if [ meier 2@ dminus 2constant emil ] endif emil 2dup cr d. 0. cr q. meier 2@ emil d+ d.
: HU create -1 , 2 , -3 , 4 , assembler ;code <nop> <nop> <nop> 1, 1, 1, end-code  HU ha <ret> 1, c0 @ 100 dump ' ha idx>xec
: TT cr c0 @ enter begin cr dup u. bs 3A  emit space #dcm char+ entry dup @ 0= esc? or until drop cr ;
: Cy flg 1 and ; : Z flg 40 and ; : Cy? cy . ; : Z? Z 0=/= 1abs . ; : flg? flg flg>smb type space ;

voc-link ddup u? @ - here c-here over $. dup $. voc-link ddup $. @ - $. cr wordlist emil cr c-here $. here $.

include" 4th/test.f8"  fence u? i-fence u? c-fence u? seal xprotect forth forth fence! fence u? i-fence u? c-fence u?
include" 4th/test.f8"  ]] here dup 11 dump ans bl word rvoc count type cr print cr [[ bel
include" 4th/test.f8"  include" /usr/src/forth/mhx/magic.frt" ]] noop here bel dup 10 u.r @ 10 u.r cr rdump [[    
compiler call-by-uot   tick include" 4th/test.f8"  compiler  call-by-uot   include" 4th/4/bench.4th" tick 2swap d-
also tools c-here 80 dump ]] 10 0 do i . i 5 = if i noop leave endif noop i . loop [ rdump dcm u. c-here u. ( ans-mode {leave} )

\ --------------------------------------------------------------------------------------------------------------------
\ uot vs immedate disp calling - {fast-call}

: fast-vari create 0 , ; : fast-create create ; fast-end : vari create 0 , ;  ' fast-vari idx>xec c-here 20 + over- dump
set-cal tick drop fld ! include" 4th/test.f8" tick drop minus fld +! fld @ #. fld @ 0 ti-cal um/mod . 100 u* ti-cal um/mod . .

\ --------------------------------------------------------------------------------------------------------------------
\ check non-/mmx words

1 if
 -1 0 10 2rshift 12 ud.r 0 -1 10 2rshift 12 ud.r -1 0 10 2lshift 12 ud.r 
 0 -1 10 2lshift 12 ud.r -1 0 10 2rshifta 12 ud.r 0 -1 10 2rshifta 12 ud.r cr
 -1 0 30 2rshift 12 ud.r 0 -1 30 2rshift 12 ud.r -1 0 30 2lshift 12 ud.r 
 0 -1 30 2lshift 12 ud.r -1 0 30 2rshifta 12 ud.r 0 -1 30 2rshifta 12 ud.r cr
endif
    
\ --------------------------------------------------------------------------------------------------------------------
\ timing tests, 'time&date'

] mtlock tick 2>r 100000 0 do i i 2drop loop tick 2r> d- d. mtunlock [
] mtlock tick 2>r 100000 0 do i i 2drop loop tick 2r> d- d. mtunlock [
] mtlock tick 2>r 100000 0 do i 1 and if i else i endif drop loop tick 2r> d- d. mtunlock [
] mtlock tick 2>r 10000 0 do in @ >r fig -find sp! r> in ! loop tick 2r> d- mtunlock d. [ 
\  !!!  1st push: 0. 7fffffff.
] mtlock tick 2>r 100000 0 do time&date 6 ndrop loop tick 2r> d- mtunlock 2dup 2rot dmin 2-rot dmax 2swap [
] mtlock tick 2>r 100000 0 do time&date 6 ndrop loop tick 2r> d- d. mtunlock [

\ \\\\\\\\\\\\\\\\\\\\\\\\\
: timer-reset s0 @ 2 >loc tick rot 2! ; 
: .elapsed tick 1 locals? if s0 @ 8- 2@ -2 >loc else 2dup endif d- drop ti-cal -dup 0= if set-cal ti-cal endif frac. ; 
: INNER #1000 0 DO 34 DROP  LOOP ; 
: BENCH TIMER-RESET #1000 0 DO INNER LOOP .ELAPSED ; 
: B*100 TIMER-RESET #100000 0 DO INNER LOOP .ELAPSED ; 
\ /////////////////////////

\ --------------------------------------------------------------------------------------------------------------------

\ conditional...
0 -dup -enter 10 enter begin 1- entry entry dup . dup 0= until drop
fig sp! 100 begin 1- dup while dup . dup 50 > dup . while dup minus . dup 0= until
] 1 2 3 4 2>r 2>r r0 @ rp@ - enter begin dup rp@ + @ abs>4th u. 4- entry dup 0< until 2rdrop 2rdrop [
ans 1 begin dup while dup 1+ dup 10 < while dup . repeat bel else dup ." hier " . then

\ --------------------------------------------------------------------------------------------------------------------

\ literal
fig sp! here ] 1 drop 1 drop 1 drop literal literal . . cr [

\ quad compiling
] bel bel quad 1234567890abcdef.fedcba0987654321 cr .s cr uq. cr dcm drop rdump [
] bel bel quad 1111111122222222.3333333344444444 cr .s cr uq. cr dcm drop rdump [

\ double mul -> quad
]] tick 2>r #1000000 0 do 1 2 100. umd* 4drop loop tick 2r> d- 2dup d. cr 
   tick 2>r #1000000 0 do 1 2 100. probier 4drop loop tick 2r> d- 2dup d. cr [[

\ +/- roll
fig sp! 10 1 do i 11 * loop cr .s 6 roll cr .s -6 roll cr

\ voc
current dup u. #17 8* dup -rot - swap dump fig sp!
here 100 erase here 40 dump head EMIL rdump c0 @ 20 tdump
 
\ exchange @tos and @tor
fig sp! cr ] 1 2 3 4 .s cr 2>r .s cr 2r>>2r .s cr 2r>>2r .s cr 2r> .s cr [ sp!
fig sp! cr ] 1 2 .s cr >r .s cr r>>r .s cr r>>r .s cr r> .s cr [ sp!

\ time->date ( n -- )
0 #60 um/ #60 um/ #24 um/ #365 um/ drop #1970 + ." Y:"#. #30 /mod 1+ ." M:"#. 1+ ." D:"#. ." h:"#. ." m:"#. ." s:" #.

\ numeric date, from {time} etc.
fig sp! time drop 0 #60 um/ #60 um/ #24 um/ 2dup #1461 um/ rotd d- #365 um/ drop \
#1970 + ." Y:"#. #30 /mod 1+ ." M:"#. 1+ ." D:"#. ." h:"#. ." m:"#. ." s:" #.

\ bits
sp> hex pad 100 erase pad 20 + on pad 30 #32 * 0 do dup i btst if i . key drop endif loop

\ constant, integer, value
hex 1234 constant ccc 5678 integer iii 90ab value vvv : ttt ." C:" ccc . ." I:" iii . ." V:" vvv . ; see ttt

\ --------------------------------------------------------------------------------------------------------------------
\ text

\ -trailing
s"       hallo     hu          ha hi !              ?" begin -trailing dup if 2dup type .s cr 1- endif -dup 0> 0= until drop

\ search strings
s" ene mene muh" pad place s" mene" pad count 2swap search . type cr pad count s" blh" search . type cr
hh s" <!--" pad place pad count s" -->" 2-rot ]] >rr search . r> [[ /string 2dup 2rot ]] >rr search . r> [[ /string
s" Ein Neger mit Gazelle zagt im Regen nie!" pad swap 2dup 4+ erase >move< pad zcount type
hex  hh s" &nbsp;" pad place pad count s" &NBSP;" 1 temp $1000    replace cr
sp> test s" me" pad place pad count s" 'na" sslice type "|< emit cr cr type "|< emit cr
   
\ display character sets
0 4 do cr i g1 #256 #32 do cr #16. do i j + dup #10 = over #127 = or if drop else dup -6 .r emit endif loop #16 +loop cr -1 +loop

\ get env vari
s" HOME=" \
100 1 do i envstg dup 0= -leave dup if 2over rot drop dup -rot compare 0= if 2drop i envstg leave endif else 2sdrop endif loop
\ display all env's
0 begin 1+ dup envstg dup while type cr repeat 3drop 

\ --------------------------------------------------------------------------------------------------------------------
\ channels

\ open-file
s" /F/lib4th/lakerkak" r/w open-file .
s" /F/lib4th/lakerkak" r/w open-file . dup . pad 110 2dup erase dump pad 100 rot read-line . . rdump

\ test file-input:			    <eof> <error>   <flg>
7FFFFFFF begin pad 100 3 read-line 3dup 0 q0= swap 0< or swap 0= or 0= if pad over type - cr 1 endif 0= esc? or until

\ copy-file
s" /F/lib4th/lakerkak-cy" 2dup w/o create-file . -rot 3 - r/o open-file . 2dup swap over file-size pad off pad swap copy-file .

\ rename-file
pad2 80 + dup ( src:) s" /F/lib4th/kakerlak" rot place count ( dst:) s" /F/lib4th/lakerkak" rename-file . 
pad2 80 + dup ( src:) s" /F/lib4th/lakerkak" rot place count ( dst:) s" /F/lib4th/kakerlak" rename-file . 

\ test for include... and {key} variants w. console vs. file input
]] blk @ >r source-id >r stdin >r 3 (stdin) ! begin interpret refill 0= until r> (stdin) ! r> (source-id) ! r> blk ! [[
s" tests/in/f8t-17.in" r/o open-file . begin dup (stdin) ! key? if key . else [ stdin ] literal (stdin) ! 0 endif -dup 0= until
s" tests/in/f8t-17.in" r/o open-file . begin dup (stdin) ! key? if key emit else [ stdin ] literal (stdin) ! 0 endif -dup 0= until
s" tests/in/f8t-17.in" r/o open-file . begin dup (stdin) ! ?key if emit else [ stdin ] literal (stdin) ! 0 endif -dup 0= until
s" tests/in/f8t-17.in" r/o open-file . begin dup (stdin) ! ekey? if key emit else [ stdin ] literal (stdin) ! 0 endif -dup 0= until
s" tests/in/f8t-17.in" r/o open-file . begin dup (stdin) ! ?ekey if emit else [ stdin ] literal (stdin) ! 0 endif -dup 0= until
s" tests/lakerkak" r/o   open-file 0= if [_] \ endif new-chan dup value  infile is-chan .
#16 3 do i 2+ i chp ! i i . ch-eof . cr loop

\ --------------------------------------------------------------------------------------------------------------------

( lsof display columns: COMMAND     PID USER   FD   TYPE     DEVICE     SIZE      NODE NAME )
