\ ff.ff  ff automatically compiles this file at boot
\ $Id: ff.ff,v 1.20 2010-01-04 16:22:17 lavarec Exp $

\ Look in this file for conditionally compiled utilities, beginning either
\ with [1] [IF] (compiled) or with [0] [IF] (not compiled).

."\\_Loading'ff.ff:_help"
"help`" find 2drop '`' which@ 6+ c! \ to be deleted by hid'm
: help` \ <name> -- ; display help for <name>, or for "help" by default
  wsparse 0= IF 2drop "help" THEN
  [` 2>r "'ff.help" needed 2r> `] 0; \ dup this line for your own help file(s)
  !"no_help_found_for_this_word"

: within over- -rot - u> 2drop nzTRUE ? zFALSE ;  \ n [ ) -- ; nz?
: max` >` IF` swap` THEN` nip` ;  \ n2 n1 -- max(n2,n1)
: min` <` IF` swap` THEN` nip` ;  \ n2 n1 -- min(n2,n1)

: pick` \ xn..x0 n -- xn..x0 xn
  \ must be preceded by "52(push edx)6Axx(push byte)5A(pop edx)"
  here 4- @ $FE00FFFE& $5A006A52- IF !"is_not_preceded_by_a_constant" ;THEN
  drop -3 allot  here 1+ c@ 1- 0= IF drop ;THEN  \ "52(push edx)"=over` C=1
  0< IF drop swap` nipdup` ;THEN  \ i.e. dup`
  $5C8B, s08 10 << $24+ w, ;  \ 8B5C24xx(mov ebx,[esp+4n])
\ $89%11&sd(mov d,s) 0:eax 1:ecx 2:edx 3:ebx 4:esp 5:ebp 6:esi 7:edi
: rp@` over` $C389, s01 ;  \ 89C3(mov ebx,eax) -> 89D8(mov eax,ebx)
: sp@` over` $E389, s01 ;  \ 89E3(mov ebx,esp) -> 89DC(mov esp,ebx)
\ : rsp!` >C1 $D089DC89, s08 s08 2drop` ;  \ rp sp -- ; for multitasking

constant` ' alias equ` \ shorter, and more usual for assembly programmers

\ --------------------------------------------------------------------
\ ?ior malloc/free lseek ioctl/select

[os] [IF] \ Linux

variable ior \ I/O result, error when negative:
: ?ior 0- ior! \ n -- ; displays system error message
  0< IF ior@ negate 1 libc. strerror 1 libc. puts  !"system_call_failed" THEN
;

: malloc 1 libc. malloc    ; \ # -- @ ; see "man malloc"
: free   1 libc. free drop ; \ @ --

\ syscall values see /usr/include/asm-i386/unistd.h
: lseek  3  19 syscall ; \ wh off fd -- off ; wh=0:SET 1:CUR 2:END
: ioctl  3  54 syscall ; \ int ioctl(int fd, int request, void* arg);
: select 5 142 syscall ; \ timeval* exceptfds* writefds* readfds* n -- ?

[ELSE] \ Windows

\ ior ?ior defined in ffwinio.asm

: malloc 0 2 k32. LocalAlloc     ; \ # -- @ ; 2ndArg:LMEM_FIXED=0
: free     1 k32. LocalFree drop ; \ @ -- ;   see win32.hlp

: lseek \ wh off fd -- off ; wh=0:SET 1:CUR 2:END
  0 -rot 4 k32. SetFilePointer  \ -- off ; 3rdArg:LP_OFFSET_HIGH=NULL
  ior@  over ?ior  ior!  \ leaves ior unmodified, as under Linux
;

[THEN]

\ --------------------------------------------------------------------
\ call back

[os] [IF] \ Linux
: 'callback:`  '` :` \ xt <name> -- ; .. arg1 arg0 ret -C- .. arg1 arg0 ; 28/
  \ 5A(pop edx)8D8424.00FFFFFF(lea eax,[esp-256])94(xchg eax,esp)
  \ 52(push edx)60(pusha) \ -- ret eax ecx edx ebx esp ebp esi edi
  \ 94(xchg eax,esp)5B(pop ebx)5A(pop edx)94(xchg eax,esp)E8.long(call xt)
  $24848D5A, ,4 $FFFF'FF00, ,4 $94605294, ,4 $E8945A5B, ,4  here 4+ - ,
  \ 895C24.1C(mov[esp+28],ebx)61(popa)C2.0001(ret 256)
  $1C245C89, ,4 $0100C261, ,4  anon:`
;
[ELSE] \ Windows
: 'callback:` !"Not_yet_implemented:_who_wants_to_contribute?" ;
[THEN]

\ --------------------------------------------------------------------
\ console input

[os] [IF] \ Linux

[0] [IF] \ cancelled because far from perfect; /usr/bin/cle works better
\ For command line edition and history:
"EMACS" 1_ libc. getenv ; \ -- ? ; in emacs shell buffer?
[IF]   \ use emacs editing keys bindings.
[ELSE] \ use GNU "readline" in a terminal:
"libreadline.so.5" lib: libreadline
: libreadline.` wsparse libreadline lit` #call ' call, ;

\ Allow conditional parsing of the ~/.inputrc file ($if ff ... $endif):
,"ff^@" anon: here 3- "rl\_readline\_name" libreadline ! ;

: rl_accept \ @ # -- n ; see help accept
\ cr      \ char* readline(const char* prompt);
  0 1 libreadline. readline \ -- @ # @malloc ; no prompt
  0- 0= IF nip nip ;THEN    \ -- 0 ; readline: empty line + EOF --> NULL
  dup>r 1 libc. strlen      \ -- @ # #' | -- @malloc
          \ void add_history(void);
  0- IF r 1 libreadline. add_history drop THEN \ don't save empty lines
  > IF nipdup r + 10 overc! swap 1+ swap THEN drop \ append newline if room
  tuck r -rot cmove         \ -- # | -- @malloc ; save to @
  r> free                   \ -- # ; free readline buffer
; rl_accept ' accept !^ ;

variable `rlH \ headers pointer saved between two rl_completions calls
: rl_completions  \ state zt@ -- @malloc
  swap 0- drop 0= IF H@ `rlH! THEN   \ state=0: init rlH
  dup 1 libc. strlen  `rlH@ 5+       \ -- zt@ # rlH+5
  START r> dupc@ 7+ +                \ -- zt@ # rlH+5
  ENTER dupc@ 0- drop 0= IF 2drop 0_ \ -- 0 ; end of headers
    ;THEN >r 2dup r 1+ swap $- drop  \ -- zt@ # | -- rlH+5
  0= UNTIL 2drop r>                  \ -- rlH+5 ; match
  c@+ 1+  2dup+ `rlH!                \ -- rlH+6 n ; 1+ for zt symbol
  dup malloc  place                  \ -- @malloc
;
rl_completions 'callback: rl_completions_cb
\ rl_completions_cb ' "rl\_completion\_entry\_function" libreadline ! ;
\ seems to work ok, but "segmentation error" when typing carriage-return
[THEN]
[THEN] \ cancelled

variable `fdset  0 , 0 , \ for select, the 2 zeros are a null timeval
: key? stdin
: `fdin? \ fd -- ; returns zFALSE if file-descriptor fd would wait for input
  1 swap << `fdset! \ fd_set READ; select will return 0 or 1 (or 0<)
  `fdset 4+ 0 0 `fdset $20 select dup ?ior 0- drop
;
: `TCGETS  $5401 SKIP \ see termios
: `TCSETSW $5403 THEN eob swap stdin ioctl ?ior ;
: ekey \ -- c ; raw access to keyboard input
  \ not yet perfect: line-discipline-control-chars still interpreted,
  \ more to patch in termios structure...
  `TCGETS eob 12+ dup@ swap &100 over! \ -- n eob+12 ; raw
  `TCSETSW key -rot ! `TCSETSW
;

[ELSE] \ Windows

: key? \ -- ; nz? ; returns zFALSE if key would wait for available data
[0] [IF] \ generic input access with WaitForSingleObject:
  stdin 0 swap 2 k32. WaitForSingleObject dup ?ior \ dwMilliseconds hHandle
  0- drop zFALSE ? nzTRUE \ WAIT_FAILED=-1 WAIT_OBJECT_0=0
[ELSE] \ WindowsConsole direct access (but also returns mouse events):
[0] [IF] \ as in Reva
  eob 1 over 4+ stdin \ lpNbEventsRead nLength lpInputRecord hConsoleInput
  4 k32. PeekConsoleInputA 1- ?ior  eob@ 0- drop
  \ PeekConsoleInputA and ReadConsoleInputA take same 4 arguments; inputRecord:
  \ 0:evtype(1=key) 4:kDn 8:repCnt 10:vkey 12:vscan 14:ascii 16:E'CSNs'ccaa
  \ Enhanced(kpad) CapsScrollNum(locks) shift ctrlLeftRight altLeftRight
[ELSE] \ simpler:
  eob stdin 2 k32. GetNumberOfConsoleInputEvents 1- ?ior eob@ 0- drop
[THEN]
[THEN]
;
: `GCM stdin 2 k32. GetConsoleMode 1- ?ior ; \ @ --
: `SCM stdin 2 k32. SetConsoleMode 1- ?ior ; \ mode --
: ekey \ -- c ; raw access to keyboard input
  \ not yet perfect: doesn't see ESC F1..F12 padKeys -> ReadConsoleInputA ?
  eob `GCM eob@  0 `SCM  key  swap `SCM
;

[THEN]

: stopdump? [os] [IF] key 10- [ELSE] key 13- key 10- | [THEN] drop ;
: ;dump` ;` BEGIN 16 bounds under 2dump stopdump? UNTIL drop ;  \ @ --
: .dec base@ 10 base! swap . base! ;  \ n -- ; display in decimal
: .dec\ base@ 10 base! swap .\ base! ;  \ n -- ; display in decimal

\ --------------------------------------------------------------------
\ console display control (topleft=0,0)

[os] [IF]  \ Linux: ANSI console (native topleft=1,1 translated to 0,0)

: cls` ( -- ) ."^[[2J"
: home ( -- ) 0 dup
: atxy ( xCol yRow -- ) ."^[[" 1+ .\ .";" 1+ .\ ."H" ;
[1] [IF] ."_normal" \ symbolic attributes and color names
: `color ( n -- ) ."^[[" .\ ."m" ;
: normal 0 `color ;     : bold 1 `color ;          : dim 2 `color ;
: underline 4 `color ;  : blink 5 `color ;         : inverse 7 `color ;
: concealed 8 `color ;  : foreground 30+ `color ;  : background 40+ `color ;
0 constant black  1 constant red      2 constant green  3 constant yellow
4 constant blue   5 constant magenta  6 constant cyan   7 constant white
[THEN]

[ELSE]  \ Windows

: `gcsbi  eob 4+  dup stdout 2 k32. GetConsoleScreenBufferInfo drop ;
\ CONSOLE_SCREEN_BUFFER_INFO{dwSize,dwCursorPos,wAttr,srWindow,dwMaxWinSize}
\ COORD{wHorX,wVerY}  -4{0,0,rX,bY}     6{wChar,wAttr}{l,t,r,b}
: cls` ( -- )
  `gcsbi  6+ 32 over w!  dup 6-  \ 6:lpFill{wChar,wAttr} 0:dwDestOrigin
  0  over 4- 2dup !  stdout  \ lpClipRect -4:lpScrollRect hConsoleOutput
  5 k32. ScrollConsoleScreenBufferA drop
: home ( -- ) 0 dup
: atxy ( x y -- ) 16 << | stdout 2 k32. SetConsoleCursorPosition drop ;
[1] [IF] ."_normal" \ symbolic attributes and color names
0 constant black  1 constant blue     2 constant green   3 constant cyan
4 constant red    5 constant magenta  6 constant yellow  7 constant white
: bright 8+ ;  \ example: "red bright foreground"
: normal     $07 $00           SKIP  \ white foreground black background
: inverse    $70 $00      SKIP       \ black foreground white background
: background 16* $0F SKIP            \ c --
: foreground     $F0 THEN THEN THEN  \ c --
  `gcsbi 8+ w@ & |  stdout  2 k32. SetConsoleTextAttribute drop
;
[THEN]

[THEN]

\ --------------------------------------------------------------------
[1] [IF] ."_.now" \ Calendar date and time display
: `leap .dec\ ."-2-29" drop ;
: .d ( n -- ; display days since 0-0-0 as gregorian date )
  146097 /% 400* swap 146096 = drop IF swap 400+ `leap ;THEN
  36524 /% 100* rot + swap
  1461 /% 4* rot + swap 1460 = drop IF swap 4+ `leap ;THEN
  365 /% rot + swap \ -- y rem
  dup 31+ 5* 153/ 2+  tuck 1+ 153* 5/ 123- - -rot  \ -- d y m
  12 > drop IF 12- swap 1+ swap THEN swap \ -- d m y
  .dec\ ."-" .dec\ ."-" .dec\ ;
: .wd ( n -- ) 7% 3* "wedthufrisatsunmontue" drop + 3 type ;
: now  \ -- n ; returns number of seconds since 2000-3-1_0:0:0
[os] [IF]  \ Linux
  0 1 13 syscall [ 1970-1-1 2000-3-1- 24:0:0* 1:0:0+ ] lit + ;
[ELSE]  \ Windows
  eob 1 k32. GetLocalTime drop  \ LPSYSTEMTIME{WORD y,m,wd,d,h,m,s,ms}
  eob w@+ 2000- swap w@+ >rswapr>  \ -- @ y m
  3 < drop IF 12+ swap 1- swap THEN  1+ 153* 5/ 123-  \ -- @ y' md
  over 365* + over 4/ + over 100/ - swap 400/ +  \ -- @ ymd
  swap 2+ w@+ rot + 24* swap w@+ rot + 60* swap w@+ rot + 60* swap w@ + ;
[THEN]
: .now` ( -- ) now dup 24:0:0/ .wd space       \ display current date&time
: .dt ( n -- ) 24:0:0 /% 2000-3-1+ .d ."\_"    \ display seconds as date&time
: .t  ( n -- ) 60 /% 60 /% .dec\ .":" .dec\ .":" .dec ; \ display seconds as time
[THEN]

\ --------------------------------------------------------------------
[1] [IF] ."_{{{" \ Performance measurement: {{{ sample code }}}
\ First try "{{{  }}}" to measure the measurement overhead
\ 50(push eax)0F31(rdtsc)89C2(mov edx,eax)58(pop eax)
: rdtsc` over` >S1 $89310F50, ,4 $58C2, ,2 ;  \ read i386 time-stamp counter
create ts 64 allot
: {{{` ( -- ) "ts_16_TIMES_dup>r_rdtsc_swap_!" eval ;
: }}}` ( -- ) "rdtsc_r>_tuck-!_4+_REPEAT_drop_;" eval
  ts 16 TIMES @+ negate . REPEAT drop cr ;
[THEN]
[os] [IF]  \ Linux
: ms@  \ -- n ; get current milliseconds count
  eob  0 over 2 78 syscall drop  2@ 1000* swap 1000/ + ;
: ms  \ n -- ; wait n milliseconds
  1000 /% swap 1'000'000* swap eob 2!  0 eob 2 162 syscall drop ;
[ELSE]  \ Windows
"GetTickCount" k32 0 fun: ms@  \ -- n ; get current milliseconds count
: ms  \ n -- ; wait n milliseconds
  1 k32. Sleep drop ;
[THEN]

\ --------------------------------------------------------------------
\ OS shell/command interface

\ Note: literal strings are already zero-terminated.
\ Note: as wsparse considers the NUL character as whitespace, NUL may replace
\ any other whitespace (HT,LF,VT,FF,CR,space) without breaking source code.
: zt  \ @ # -- @ ; append zero-terminator
  over+ 0 swap c! ;

[os] [IF]  \ Linux shell interface

: man` >in@ 4- lnparse + over- \ <mantopic> -- ; 4-:"man_" fallthru
: shell  \ @ # -- ; send command to shell, command result into ior
  zt 1 libc. system 0; ior! !"shell_call_failed"
: cd`    \ <newdir> -- ; change directory
  wsparse zt 1 12 syscall ?ior
;
: !!`    \ <line> -- ; send command line to shell
  lnparse shell ;

[ELSE]  \ Windows command interface:

create `STARTUPINFO 72 allot ; `STARTUPINFO 72 2dup 0 fill swap !
: win32.hlp` "winhlp32.exe_win32.hlp" \ fallthru
: shell  \ @ # -- ; send command to shell, command result into ior
  tuck "cmd_/c_" eob place 7+ place + 0 swap c!  \ zero-terminated at eob
  here  \ lpProcessInformation{hProcess,hThread,dwProcessId,dwThreadId}
  `STARTUPINFO 0 0  \ lpStartupInfo lpCurrentDirectory lpEnvironment
  $20  \ dwCreationFlags=NORMAL_PRIORITY_CLASS
  0 0 0  \ bInheritHandles  lpThreadAttributes lpProcessAttributes
  eob 0  \ lpCommandLine lpApplicationName
  10 k32. CreateProcessA 1- ?ior  \ returns BOOL, 1:ok 0:failed
  15000 here @  \ dwMilliseconds hHandle
  2 k32. WaitForSingleObject ?ior  \ -1:failed
  ior here @  \ lpExitCode hProcess
  2 k32. GetExitCodeProcess drop
;
: cd`    \ <newdir> -- ; change directory
  wsparse zt 1 k32. SetCurrentDirectoryA 1- ?ior
;
: !!`    \ <line> -- ; send command line to shell
  lnparse shell ;

[THEN]

\ --------------------------------------------------------------------
[1] [IF] ."_+longconds" \ long conditionals
\ ff.boot default conditionals are limited to byte offsets for forward jumps
\ (backward jumps use byte offsets when possible, otherwise long offsets):
\ this is efficient and encourages programmers to write small definitions.
\ Would you ever need to write bigger definitions requiring long offsets,
\ this is for you: type "+longconds" to switch to long forward conditionals;
\ you can also type "-longconds" to switch back to byte forward conditionals;
\ WARNING: DON'T switch forth or back in the middle of a control structure!

\ 72:bc/aenc 74:z/nz 76:be/a 78:s/ns 7C:l/ge 7E:le/g (long:+0F10)
\ E0:loopnz/loopz E2:loop/jecxz(byte) E8:call/jmp(long) EB:jmp(byte)

: `then here over- 4- swap ! ;
: IF' `cond $0F c, $10+ c, here SC c@ , ;
: SKIP' $E9 c, here SC c@ , ;
: ELSE' SKIP' swap dupc@ SC c!
: THEN' dupc@ >SC `then ;
: ;THEN' ;;` dupc@ SC c! `then ;
: START' $90 c, align` $E9 here 1- c! 0 , BEGIN` ;
: TIMES' >r`
: RTIMES' BEGIN` $880F08FF , 0 , ;  \ dec[eax] js.l
: ENTER' `mrk@ dup 3& >SC -4& 4- `then ;
: WHILE' `mrk 2@ 3& >SC `cond $0F c, $10+ c, here `mrk 4+ ! , ;
: BREAK' `mrk 2@ 3& >SC              $E9  c, here `mrk 4+ ! , THEN' ;
: CASE' =` drop` IF' drop` ;
: AGAIN' $EB `-jmp THEN' ;
: UNTIL' TILL`
: END' `mrk 2@ dup 3& >SC -4& swap \ -mrk +mrk
  START dup@ swap `then ENTER = UNTIL \ -mrk -mrk
  @ $880F08FF- 0= drop IF under 4+ `then rdrop` THEN \ balance RTIMES
  drop `mrk 2! ;
: REPEAT' $EB `-jmp END' ;
: -longconds'  \ -- ; remove headers -longconds`..IF`
  [ "`then" find 2drop which@ H@ - constant `size ]
  "-longconds`" find IF !"-longconds`_not_found" ;THEN 2drop
  H@ which@ START 1- dupc@ over `size+ c! ENTER = UNTIL drop `size+ H! ;
: +longconds`  \ -- ; copy headers -longconds'..IF' -> -longconds`..IF`
  "-longconds'" find 2drop which@ `size H@ dup>r over- place dup H!
  '`' swap BEGIN 5+ dupc@ + 2dupc! 2+ r = drop UNTIL 2drop rdrop ;

[THEN]

\ --------------------------------------------------------------------
[0] [IF] ."_compat" \ RetroForth/Reva/HelFORTH compatibility words
\ RetroForth/Reva control structures (see also "help conditionals")
\ 72:bc/aenc 74:z/nz 76:be/a 78:s/ns 7C:l/ge 7E:le/g (long:+0F10)
\ E2:loop/jecxz(byte) E8:call/jmp(long) EB:jmp(byte)

: if`    $840F  : `if1 $DB09, s09  : `ifx drop` w, here SC c@ , ;
: 0=if`  $850F `if1 ;
: 0<if`  $890F `if1 ;
: 0>=if` $880F `if1 ;
: =if`   $850F  : `if2 $DA39, s09 drop` `ifx ;
: <>if`  $840F `if2 ;
: <if`   $8D0F `if2 ;
: <=if`  $8F0F `if2 ;
: u<if`  $830F `if2 ;
: u<=if` $870F `if2 ;
: ;then` ;;` dupc@ SC c!
: then` dupc@ >SC here over- 4- swap ! 0 callmark ! ;
: else` $E9 c, here SC c@ , swap then` ;

: for` >r`
: repeat` here SC c@ ;
: again` >SC 0 SC c! here - dup -$7E <if $E9 c, 5- , ;then
  $EB c, 2- c, ;
: while` $DB09, s09 drop` >SC here - dup -$7E <if $850F w, 6- , ;then
  $75 c, 2- c, ;
: next` >SC here - dup -$7C <if $8F0F08FF , 8- , rdrop` ;then
  $FC7F08FF , here 1- +! rdrop` ;

: `;loc which@ 5+ c@+ + 1+ H! ;  \ -- ; restore H after last found header
: loc:`  ";loc`" `;loc ' 0 header ;  \ -- ; see also FreeForth hid'm

[THEN]

\ --------------------------------------------------------------------
[1] [IF] ."_f." \ Uses FPU hardware stack: 8-cells * 80-bits(tword)
\ Stack notation: "f:x" represents 80-bits float "x" on FPU stack
10 constant fcell \ fcell+ fcell- fcell* fcell/ (see literalcompiler)

\ FPU Status-Word(ro) and Control-Word(rw) access:
  \ 8D40FC(eax-=4)DD38(fnstsw[eax])871087DA(xchg edx,[eax] xchg ebx,edx)
: fsw@ ,"^M~@|~]~8^G~^P^G~Z~" ; \ -- w ; don't care MSword: use .w
  \ 8D40FC(eax-=4)D938(fnstcw[eax])871087DA(xchg edx,[eax] xchg ebx,edx)
: fcw@ ,"^M~@|~Y~8^G~^P^G~Z~" ; \ -- w ; don't care MSword: use .w
  \ 87DA8710(xchg ebx,edx xchg edx,[eax])D928(fldcw[eax])8D4004(eax+=4)
: fcw! ,"^G~Z~^G~^PY~(^M~@^D" ; \ w -- ; don't care MSword
  \ C740FC.7F07'7F03(mov[eax-4],$037F'077F) nearest'-infinity  '0F7F=truncate
  \ D968FC(fldcw[eax-4])D9FC(frndint)D968FE(fldcw[eax-2])
: floor ,"G~@|~^?^G^?^CY~h|~Y~|~Y~h\~~" ; \ f:i.f -- f:i.0 ; integer part

\ Convert between 32-bits integer on DATAstack and 80-bits float on FPU stack
  \ 8D40FC(eax-=4)DB18(fistp dw[eax])871087DA(xchg edx,[eax] xchg ebx,edx)
: f>s ,"^M~@|~[~^X^G~^P^G~Z~" ; \ f:n -- n ; convert float to single int
  \ 87DA8710(xchg ebx,edx xchg edx,[eax])DB00(fild dw[eax])8D4004(eax+=4)
: s>f ,"^G~Z~^G~^P[~^@^M~@^D" ; \ n -- f:n ; convert single int to float

\ Convert between 64-bits C-double on DATAstack and 80-bits float on FPU stack
\ (for interfacing with C dynamic libraries using double floats)
  \ 8D40F8(eax-=8)DD18(fstp qw[eax])8718875004(xchg ebx,[eax] xch edx,[eax-4])
: f>df ,"^M~@x~]~^X^G~^X^G~P^D" ; \ f:df -- df ; convert float to C-double
  \ 8718875004(xchg ebx,[eax] xchg edx,[eax-4])DD00(fld qw[eax])8D4008(eax+=8)
: df>f ,"^G~^X^G~P^D]~^@^M~@^H" ; \ df -- f:df ; convert C-double to float

\ Class2 = FPU macro, inlines 1 or 2 FPU instructions embedded in its header:
: `f:` ;` wsparse rot 2 header ; \ FPUinstr <name> -- ; class2 definer
: `f, dup lit` $FFFF0000& drop IF ,` ;THEN w,` ; \ postpone, immediate;
: `f; dup      $FFFF0000& drop IF ,  ;THEN w,  ; `f, ' `f; ' classes &20+ 2! ;

$E3DB `f: finit` \ fninit  initialize FPU cw=$037F sw=$0000
$EED9 `f: 0.`  \ fldz
$E8D9 `f: 1.`  \ fld1
$EBD9 `f: fpi` \ fldpi
$C0D9 `f: fdup`  \ fld st0
$C1D9 `f: fover` \ fld st1
$D8DD `f: fdrop` \ fstp st0
$D9DD `f: fnip`  \ fstp st1
$C9D9 `f: fswap` \ fxch st1
$C1D9C9D9 `f: ftuck`  \ fswap` fover`
$C9D9C1D9 `f: funder` \ fover` fswap`
$CAD9C9D9 `f: frot`   \ fswap`  fxch st2
$C9D9CAD9 `f: f-rot`  \ fxch st2  fswap`
$C1D9C1D9 `f: f2dup`  \ fover` fover`
$D8DDD8DD `f: f2drop` \ fdrop` fdrop`

$C1DAF1DB `f: `fmax`  \ fcomi  fcmovb st1
$D1DBF1DB `f: `fmin`  \ fcomi  fcmovnbe st1
: fmax` `fmax` fnip` ;
: fmin` `fmin` fnip` ;
$E0D9 `f: fnegate` \ fchs
$E1D9 `f: fabs`
$C1DE `f: f+`  $C1D8 `f: fover+` \ faddp  fadd st0,st1
$E9DE `f: f-`  $E1D8 `f: fover-` \ fsubp  fsub st0,st1
$E1DE `f: fswap-` \ fsubrp
$C9DE `f: f*`  $C9D8 `f: fover*` \ fmulp  fmul st0,st1
$F9DE `f: f/`  $F1D8 `f: fover/` \ fdivp  fdiv st0,st1
$F1DE `f: fswap/` \ fdivrp
: f1/` 1.` fswap/` ;
$FAD9 `f: fsqrt`

$EDD9 `f: `fldln2`
$ECD9 `f: `fldlg2`
$EAD9 `f: `fldl2e`
$E9D9 `f: `fldl2t`
$F0D9 `f: `f2xm1`   \ f:x -- f:2**x-1 ; |x|<=1
$F4D9 `f: `fxtract` \ f:x -- f:e=floor(lb(x)) f:x/2^e
$D9DDFDD9 `f: `fscale`  \ f:e f:m -- f:m*2^trunc(e) ; (with fnip)
$F1D9C9D9 `f: `fxl2y`   \ fxch fyl2x
$F9D9C9D9 `f: `fxl2yp1` \ fxch fyl2xp1
: fln`  `fldln2` SKIP
: flog` `fldlg2` THEN `fxl2y` ; \ lgX=lbX/lb10 lg2=lb2/lb10 => lgX=lbX*lg2
: fasinh fdup fover* 1. f+ SKIP \ ln(x+sqrt(x*x+1))
: facosh fdup fover* 1. f- THEN \ ln(x+sqrt(x*x-1))
  fsqrt f+ fln ;
: fatanh 1. fover- fln fswap `fldln2 `fxl2yp1 fswap- \ (ln(1+x)-ln(1-x))/2
: f2/ 1. fnegate fswap `fscale ;
: f2* 1. fswap `fscale ;
: f**   `fxl2y          SKIP
: faln  `fldl2e SKIP
: falog `fldl2t THEN f* THEN \ -- f:x*l2(y)
  fdup floor fswap fover-  `f2xm1 1. f+ `fscale ;
: fsinh faln 1. fover/ f- f2/ ; \ (e(x)-e(-x))/2
: fcosh faln 1. fover/ f+ f2/ ; \ (e(x)+e(-x))/2
: ftanh f2* faln 1. fover- fswap 1. f+ f/ ; \ (e(2x)-1)/(e(2x)+1)

$FED9 `f: fsin`
$FFD9 `f: fcos`
$FBD9 `f: fsincos`   \ f:x -- f:sin f:cos
$D8DDF2D9 `f: ftan`  \ fptan(-- f:tan f:1) fdrop`
$F3D9E8D9 `f: fatan` \ fld1 fpatan
$F3D9 `f: fatan2`    \ f:y f:x -- f:atan(y/x) ; fpatan
: facos fdup fover* 1. fswap- fsqrt fswap fatan2 ; \ fatan(sqrt(1-x*x)/x)
: fasin fdup fover* 1. fswap- fsqrt       fatan2 ; \ fatan(x/sqrt(1-x*x))

\ 72:bc/aenc 74:z/nz 76:be/a
: f0<` $77 : `f?1 $F1DFEED9 , `?1 ; \ fld0  fcomip st0,st1
: f0>=` $76 `f?1 ;
: f0<>` $75 `f?1 ;
: f0=` $74 `f?1 ;
: f0<=` $73 `f?1 ;
: f0>` $72 `f?1 ;
: f<` $77 : `f?2 $F1DB w, `?1 ; \ fcomi st0,st1
: f>=` $76 `f?2 ;
: f<>` $75 `f?2 ;
: f=` $74 `f?2 ;
: f<=` $73 `f?2 ;
: f>` $72 `f?2 ;
: f~ \ f:y f:x f:t -- f:y f:x ; nz?  t>0:|y-x|<t, t=0:y==x, t<0:|y-x|<|t*(y+x)|
  f0= IF fdrop f= nzTRUE ? zFALSE ;THEN \ bitwise comparison
  f0< IF fover ,"X~C~" f* fabs \ D8C3(fadd st0,st3)
  THEN   fover ,"X~c~" fabs f> f2drop nzTRUE ? zFALSE ; \ D8E3(fsub st0,st3)

: dupf!` $3BDB, s01 ; \ f:n @ -- @ ; fstp tw[ebx]
: dupf@` $2BDB, s01 ; \ @ -- @ f:n ; fld  tw[ebx]
: f+!` dupf@` f+`
: f!` dupf!` drop` ;
: f@` dupf@` drop` ;
: f,` $7DDB w, $0A6D8D00 , ; \ DB7D00(fstp[ebp])8D6D0A(lea ebp,[ebp+10])
: fvariable` create` 0. f, anon:` ;
: flit` $0AEB w, here >r f, \ jmp+10  fliteral
: `fcst $2DDB w, r> , ; \ fld tw[@]
: fconstant` \ f:n <name> -- ; -- f:n ; compiles a macro compiling "fld tw[@]"
  ;` wsparse 2dup+ dupc@ >r dup>r '`' swap c! 1+ \ append `
  here 0 header 2r> c!  `fcst ' call,  f, anon:` ;

variable f#  4 f#!  \ number of displayed digits < 20
$E5D9 `f: `fxam` \ sw&4500= 4000:ZERO 0500:INF 0100:NaN
: `fdigit fdup floor fdup f>s '0'+ emit f- fover* ; \ f:10 f:x -- f:10 f:x
: f. \ f:n -- ; display float in scientific format with f# significant digits
  f0< IF ."-" THEN fabs  `fxam fsw@ $4500&  $4000 CASE ."0._" fdrop ;THEN
  $500 CASE ."INF_" fdrop ;THEN  $100 CASE ."NaN_" fdrop ;THEN drop
  fdup flog floor f#@ 1- s>f f- falog f2/ f+ \ round LSdigit, may carry up
  fdup flog floor fdup f>s falog f/ \ -- exp f:mant
  10 s>f fswap `fdigit ."." f#@ 1- TIMES `fdigit REPEAT f2drop \ -- exp
  ."e" .dec ; \ display exponent in decimal
: f.s` \ -- ; display full stack (uses eob)
  [ $35DD w, eob , ] \ fnsave[eob]  cw[4],sw[4],env[20],stack[8*10]
  eob 4+ w@ 11 >> negate 7& \ -- #items
 [0] [IF] \ minimum display, TOS last on right:
  dup .\ .":_" eob 28+ over 10* + swap TIMES 10- dupf@ f. REPEAT drop cr
 [ELSE] \ full binary display, TOS first on top:
  eob 7 TIMES @+ .l space REPEAT cr \ FPU-environment: 7 dwords
  swap TIMES 10 TIMES r over+ c@ .b REPEAT space dupf@ f. cr 10+ REPEAT drop
 [THEN]
  [ $25DD w, eob , ] ; \ frstor[eob]

:^ `ferror !"???" \ vectorizable float-parsing-error handler
: fnumber \ @ # -- f:n ; converts string to float
  dup 2- 0< drop `ferror ?  10 s>f 0.
  bounds dupc@ '-'- >r 0= IF 1+ THEN  swap dup>r swap \ sign dpl@end
  BEGIN c@+ BEGIN \ -- @end @ c
    '.' CASE r> u> drop `ferror ?  dup>r BREAK \ dpl@
    'e' CASE r> 1+ over- 0> IF 0_ THEN -rot swap over- \ -- expn @ #
        0= `ferror ? number 0- `ferror ? -rot + >r dup BREAK \ -- 0 0
    '0'- 9 u> drop `ferror  ? fover* s>f f+
  END u<= UNTIL drop fnip  r> swap - s>f falog f*
  r> 0- 0= drop IF fnegate THEN ;
\ link float-literal-compiler to "notfound" and redefine "notfound":
: `f# fnumber flit` ;  `f# ' notfound !^  `ferror ' alias notfound

finit ; \ comment this line to disable FPU initialization when loading ff.ff
[THEN]  \ 7.5Ksource = 1.6Kcode + 1.3Kheaders

\ --------------------------------------------------------------------------
[1] [IF] ."_sqrt" \ integer square root (bit per bit algorithm, see Wikipedia)

: sqrt  \ u -- sqrt(u) ; unsigned input, rounded (or truncated [*]) output
  0 $4000'0000  \ -- u sqrt one ; u = remainder, one = current bit
  BEGIN dup>r + \ -- u sqrt+one | == one
    u< IF r - ELSE swap over- swap r + THEN \ undo(bit=0), or reduce u(bit=1)
    1 >> r> 4/  \ -- u sqrt/2 one/4 ; (note: "1 >>" doesn't propagate MSBit)
  0= UNTIL drop \ -- u sqrt ; final remainder and truncated square root
  \ [*] (un)comment the following line for a (rounded)truncated result: [*]
  u> IF 1+ THEN \ -- u sqrt ; round to nearest integer
  nip \ -- sqrt
;

[THEN]

\ --------------------------------------------------------------------------
[1] [IF] ."_uart!" \ Serial interface

\ HOWTO:
\ + list all available comm-ports:  .ports` \ Lin:ttyS0..ttyUSB0.. Win:COM1..
\ + select one of 4 UART contexts:  3 uart! \ default: 0 uart! 0 port!
\ + select context comport number:  1 port! \ max=63, Linux:32-63=ttyUSB0..31
\ + select speed and open comport:  115200 bps \ no default speed
\ + select parity (default=none) :  evenParity \ oddParity noParity
\ + display current context conf.:  .bps` \ macro-executes previous anon-def
\ + receive/send 1 byte, a buffer:  RX(--c) TX(c--) XRECV(@ #--) XSEND(@ #--)
\ + trace received and sent bytes:  utrace on  \ trace off (disable)
\ + emulate a very dumb terminal:   dumbterm   \ dumpterm  (hexa)

create COM \ UART current context
-1 , \ file-descriptor (-1=invalid)
 0 , \ bps<<8, USB<<7, port<<2 (/dev/ttyS0=COM1 /dev/ttyUSB0=USB1), context#
-1 , 0 ,  -1 , 1 ,  -1 , 2 ,  -1 , 3 , \ 4 contexts
: uart! \ n -- ; switch UART context
  COM 2@ over 3& 1+ 8* COM+ 2!  3& 1+ 8* COM+ 2@ COM 2!
;

[os] [IF]  \ Linux ---------------------------------------------------------

\ Linux implementation requires: asroot> chmod o+rw /dev/ttyS?
\ Note: /bin/stty is used to configure "raw" access to /dev/ttyS?;
\ using /bin/setserial to setup the speed allows all 115200 submultiples.
\ http://ftdi-usb-sio.sourceforge.net USB-TO-SERIAL "FTDI" converter cable:
\ - set tty->termios->c_cflag speed to B38400
\ - set your real speed in tty->alt_speed; it gets ignored when alt_speed==0

: port! \ n -- ; setup port no: 0=/dev/ttyS0 31=ttyS31 32=ttyUSB0 63=ttyUSB31
  $3F& 4*  COM 4+ @ 3& +  COM 4+ !
;
: .ports` \ -- ; displays all available ttyS* or ttyUSB* ports
  "/dev/ttyUSB0^@" "/dev/ttyS0^@"
  2 BEGIN >r 32 BEGIN >r 2dup+ 1- \ -- @ # @+#-1
    r ~ $1F& 10 /% swap '0'+ swap 0- IF '0'+ swap THEN rot tuckc! 1- c!
    2dup openr dup eob $5401 rot ioctl swap close drop 0- drop \ -- @ #
    0= IF over 5+ over 5- type space THEN
  r> 1- 0= UNTIL drop 2drop r> 1- 0= UNTIL drop
;
: bpsx  COM 2@ SKIP \ to skip "close"
: bps \ bps -- ; open UART r/w at bps bits-per-second in raw mode[n,8,1]
  COM 2@ close THEN drop  $FF& \ -- bps s ; flush serial, s with speed null
  "/bin/stty___38400_raw_-echo_cs8_-parenb_-cstopb_</dev/ttyUSB0_"
  \ 123456789012345^                                ^1098^65432^0
  dup>r swap dup>r + 1- >r \ -- bps s | == # @ @+#-1 ; setup port type&number:
  dup $80& drop IF "ttyUSB" ELSE "./ttyS" THEN r 7- place drop
  dup 4/ $1F& 10 /% 0- 0= IF $10- swap THEN '0'+ swap '0'+ r tuckc! 1- c!
\ '0'+ r 1- c! '0'+ r c!
  \ -- bps s | == # @ @+#-1
[1] [IF] \ with /bin/stty only, for standard baudrates:
  over $100* + swap r> swap r 16+ swap \ -- s @+#-1 @+16 bps | == # @
  7 TIMES 0- IF 10 /% >r '0'+ ELSE >r $20 THEN overc! 1- r> REPEAT 2drop
  \ -- s @+#-1 | == # @ ; /bin/stty command ready
[ELSE] \ with /bin/setserial (to be installed), for custom baudrates:
  tuck $80& 115'200_ IF 24'000'000_ THEN \ -- s bps clk | -- # @ @+#-1
  swap under / tuck / $100* rot + \ -- div s ; s with bps
  \ man setserial: gives 115200/divisor bps when 38400 bps asked
  "/bin/setserial_/dev/ttyUSB0__spd\_cust_divisor_______3" \ -- div s @ #
  \ 123456789ABCDE^
  over $F+ r 12- swap 13 cmove \ copy port type/number from /bin/stty command
  dup>r swap dup>r + 1- rot \ -- s @+#-1 div | -- # @ @+# # @ ; setup divisor:
  7 TIMES 0- IF 10 /% >r '0'+ ELSE >r $20 THEN overc! 1- r> REPEAT 2drop
  r> r> shell r> \ -- s @+# | == # @ ; execute /bin/setserial command
[THEN] \ -- s @+#-1 | == # @
  r> r> shell \ -- s @+#-1 ; execute /bin/stty command
  dupc@ $20- 12_ IF 1+ THEN swap 12- swap openw tuck COM 2! ?ior
;

\ variable `fdset  0 , 0 ,  \ the 2 zeros are a null timeval
\ : select 5 142 syscall ; \ timeval* exceptfds* writefds* readfds* n -- ?
\ : TX? \ -- ; nz? ; returns zFALSE if TX would wait for available space
\   1 COM@ << `fdset! \ fd_set WRITE; select will return 0 or 1 (or 0<)
\   `fdset 4+ 0 `fdset 0 $20 select dup ?ior 0- drop
\ ;
: RX? \ -- ; nz? ; returns zFALSE if RX would wait for available data
  COM@ `fdin?
;
: `waitRX \ -- c ; waits until RX? or throws KBDirq/RX when key?
  1 COM@ << 1+ `fdset! \ fd_set READ([n]=uart,[0]=stdin)
  0 0 0 `fdset $20 select ?ior \ -- ; sleep until key? or RX?
  `fdset@ 1& IF !"KBDirq/RX" ;THEN
  `io_ 1 under COM@ read ?ior c@
;

\ Linux functions for UART signals control:
\ DB9-25: 1<DCD<8 2<RD<3 3>TD>2 4>DTR>20 5-GND-7 6<DSR<6 7>RTS>4 8<CTS<5 9<RI<22
\ DB9F-0: 1<DCD<4 2<RD<1 3>TD>7 4>DTR>9  5-GND-5 6<DSR<3 7>RTS>8 8<CTS<2 9<RI<6
\ DB9F-1:        2<RD<10 3>TD>12         5-GND<5  3V3<15 7>RTS>13 8<CTS<11
\ C02kbd:         8<BLTX 7>BLRX 2>RST    1-GND           3>TCK  3>3V
\ C03kbd:         3<UTX1 2>URX1          1-GND    8>3V3         7>3V
\ see Linux Serial Programming HOWTO
\ - ioctl requests from /usr/include/asm/ioctls.h:
\ . TCGETS      5401  GETStruct termios
\ . TCSETS      5402  SETStruct termios
\ . TCSBRK      5409  SendBReaK during (int)arg*100ms
\ . TIOCMGET    5415  ModemGET signals
\ . TIOCMBIS    5416  ModemBItSet
\ . TIOCMBIC    5417  ModemBItClear
\ . TIOCMSET    5418  ModemSET signals
\ . TIOCGSERIAL 541E  GetSERIAL
\ . TIOCSSERIAL 541F  SetSERIAL
\ - TCGETS/TCSETS (struct*termios)arg bits from /usr/include/asm/termbits.h:
\ . c_cflag:              
\ CBAUD   $100F \ &10017   struct termios { // 25 bytes:
\ B4800   $000C \ &00014     uint c_iflag;  // input   mode flags
\ B9600   $000D \ &00015     uint c_oflag;  // output  mode flags
\ B38400  $000F \ &00017     uint c_cflag;  // control mode flags
\ B115200 $1002 \ &10002     uint c_lflag;  // local   mode flags
\ CS8     $0030 \ &00060     uchar c_line;  // line discipline
\ PARENB  $0100 \ &00400     uchar c_cc[8]; // control characters
\ PARODD  $0200 \ &01000   };
\ - TIOCM (int*)arg bits from /usr/include/asm/termios.h:
\ TIOCM_LOOP 8000 16:                  struct winsize {  // 8 bytes:
\ TIOCM_OUT2 4000 15>                    ushort ws_row, ws_col;
\ TIOCM_OUT1 2000 14>                    ushort ws_xpixel, ws_ypixel;
\ TIOCM_DSR  0100 8< DataSetReady      };
\ TIOCM_RI   0080 7< RingIndicator     struct termio {   // 17 bytes: obsolete
\ TIOCM_CD   0040 6< CarrierDetect       ushort c_iflag; // input   mode flags
\ TIOCM_CTS  0020 5< ClearToSend         ushort c_oflag; // output  mode flags
\ TIOCM_SR   0010 4: SecondaryReceive    ushort c_cflag; // control mode flags
\ TIOCM_ST   0008 3: SecondaryTransmit   ushort c_lflag; // local   mode flags
\ TIOCM_RTS  0004 2> RequestToSend       uchar c_line;   // line discipline
\ TIOCM_DTR  0002 1> DataTerminalReady   uchar c_cc[8];  // control characters
\ TIOCM_LE   0001 0: LineEnable        };  // struct termios: s/ushort/uint/

: DSR? $100 SKIP
: RI?  $080 SKIP
: CD?  $040 SKIP
: CTS? $020 THEN THEN THEN
  eob $5415 COM@ ioctl ?ior \ 5415=TIOCMGET
  eob@ & drop ; \ -- z?
: DTR1 $5416 SKIP         \ 5416=TIOCMBIS  5417=TIOCMBIC
: DTR0 $5417 THEN 2 SKIP  \    2=TIOCM_DTR.4  4=TIOCM_RTS.7
: RTS1 $5416 SKIP         \ MSP:~DTR=RST/NMI,~RTS=TCK/TST-VPP
: RTS0 $5417 THEN 4 THEN
  eob tuck! swap COM@ ioctl ?ior ;
: UBREAK 1 $5409 COM@ ioctl ?ior ; \ 1=100ms

: `TCGETS $5401 SKIP \ termios@ --
: `TCSETS $5402 THEN COM@ ioctl ?ior ;
: noParity   $0000      SKIP  \ default
: oddParity  $0300 SKIP
: evenParity $0100 THEN THEN $FCFF
  eob `TCGETS eob 8+ @ & | eob 8+ ! eob `TCSETS
;
: .bps` \ -- ; display current context
  ;` COM 4+ @ ."uart" dup 3& .\  dup $80& drop IF .":ttyUSB" ELSE .":ttyS" THEN
  dup 4/ $1F& .dec  eob `TCGETS  $100/ .dec ."bps_8bits_"  eob 8+ @ $300&
  BEGIN IF $200& IF ."odd" BREAK ."even" BREAK ."no" END drop ."Parity_1stop^J"
;

[ELSE]  \ Windows -----------------------------------------------------------

: port! \ n -- ; setup port number: 1=COM1 .. 64=COM64
  1- $3F& 4*  COM 4+ @ 3& +  COM 4+ !
;
: .ports` \ -- ; displays all available COM or USB ports
  "COM1^@" 64 BEGIN >r 2dup+ 1- \ -- @ # @+#-1
    65 r - 10 /% swap '0'+ swap 0- IF '0'+ swap THEN rot tuckc! 1- c!
    2dup openr  eob over 2 k32. GetCommState swap close drop \ -- @ # ?
    0- drop IF ."COM" 65 r - .dec THEN
  r> 1- 0= UNTIL drop 2drop
;
variable CommStateFlags  1 CommStateFlags! \ DCB+8:dwFlags:$01=Binary
: bps   \ bps -- ; open UART r/w at u bits per second in raw mode[n,8,1]
  COM 2@ close drop  "COM1^@" drop >r \ -- bps s | == @ ; setup port no:
  dup 4/ $3F& 1+ 10 /% swap '0'+ swap 0- IF '0'+ swap THEN r 4+ tuckc! 1- c!
  \ r> 5 openw \ -- bps s handle ; ffwinio.asm: openw uses "OPEN_ALWAYS", but
  \ win32.hlp requires "OPEN_EXISTING" for COM devices:
  0 $80 3 0 \ hTemplate, FILE_ATTRIBUTE_NORMAL, OPEN_EXISTING, lpSecurityAttr,
  0 $C0000000 r> \ FILE_SHARE_NONE, GENERIC_READ+GENERIC_WRITE, lpFileName,
  7 k32. CreateFileA \ -- bps s handle
  dup ?ior COM 2! \ -- bps
: bpsx  \ bps -- ; change baudrate without closing+opening UART
  \ see win32.hlp DCB topic for DCB structure details:
  \ DCB+4:dwBaudRate +8:dwFlags +18:bByteSize +19:bParity +20:bStopBits
  \ dwFlags: $01=Binary $02=ParityEn(0=none,1=odd,2=even) $04=CTSen $08=DSRen
  \ dwFlags: $10=DTRen $20=DTRhs $40=DSRen $1000=RTSen $2000=RTShs $3000=RTSx
  eob COM@ 2 k32. GetCommState 1- ?ior \ -- bps ; read DCB into eob
  eob 4+ tuck!  CommStateFlags@ swap 4+ tuck! \ 4:BaudRate 8:Flags=disable
  8 swap 10+ tuckw!  0 swap 1+ w! \ 8bits noParity 1stop
  eob COM@ 2 k32. SetCommState 1- ?ior \ see also Get/SetCommTimeouts:
  \ CTO: 0:RdIntervalTO 4:RdTotTOMul 8:RdTotTOCte 12:WrTotTOMul 16:WrTotTOcte
  \ default COMMTIMEOUTS:-1,0,0,1,20 = pollRead,WriteTimeOut=20ms+1ms*N
  eob dup 20 erase  8 over 8+ !  COM@ 2 k32. SetCommTimeouts 1- ?ior \ RdTO=8ms
;
: .bps`  \ -- ; display current context
  ;` COM 4+ @ ."uart" dup 3& .\  .":COM" 4/ $3F& 1+ .dec
  eob COM@ 2 k32. GetCommState 1- ?ior
  eob 4+ dup@ .dec ."bps_8bits_" 15+ c@ BEGIN \ -- bParity
    0 CASE ."no" BREAK 1 CASE ."odd" BREAK 2 CASE ."even" BREAK
    3 CASE ."mark" BREAK 4 CASE ."space" BREAK .\
  END ."Parity_1stop^J"
;
: noParity   0      SKIP
: oddParity  1 SKIP
: evenParity 2 THEN THEN
  eob COM@ 2 k32. GetCommState 1- ?ior \ -- c ; read DCB into eob
  eob 8+ dup@ 2| swap tuck!  11+ c! \ -- ; modify DCB
  eob COM@ 2 k32. SetCommState 1- ?ior
;
\ Control RTS DTR BRK modem signals:
: RTS1 3                     SKIP
: RTS0 4                SKIP
: DTR1 5           SKIP
: DTR0 6      SKIP
: BRK0 9 SKIP
: UBREAK BRK0 100 ms \ fallthru
: BRK1 8 THEN THEN THEN THEN THEN
  COM@ 2 k32. EscapeCommFunction 1- ?ior
;
\ nzTRUE ' alias TX? \ -- ; nz? ; TX will never wait for available space
\ Too bad, this doesn't work: COM appears always signalled!
\ : RX? \ -- ; nz? ; returns zFALSE if RX would wait for available data
\   COM@ 0 swap 2 k32. WaitForSingleObject dup ?ior \ dwMilliseconds hHandle
\   0- drop nzTRUE ? zFALSE
\ ;
\ : waitRX \ -- ; waits until RX? or throws KBDirq/RX when key?
\   stdin COM@ eob 2! \ handles array
\   -1 0 eob 2 \ dwMilliseconds=INFINITE bWaitAll=any *lpHandles nCount
\   4 k32. WaitForMultipleObjects dup ?ior \ WAIT_FAILED=-1 WAIT_OBJECT_0=0
\   0- 0= IF `io_ 1 under COM@ read ?ior c@ ;THEN !"KBDirq/RX"
\ ;
\ Timeout (setup by bps) must be used:
: RX? \ -- ; nz? ; returns zFALSE if RX would wait for available data
  COM 6+ c@ 0- 0= IF  COM_ 5+ 1 COM@ read COM 6+ 2dupc! drop 0-  THEN drop
;
: `waitRX \ -- c ; waits until RX? or throws KBDirq/RX when key?
  BEGIN RX? 0= WHILE key? TILL !"KBDirq/RX" END
  COM 5+ dupc@ swap 2dupw! drop
;

[THEN]  \ Linux/Windows --------------------------------------------------

variable utrace  \ default 0: no trace
: RX \ -- c ; receive one byte
  `waitRX \ wait aborted by throwing "KBDirq/RX" exception when "key?"
  utrace@ 0- drop IF ."<" dup .b THEN
;
: TX \ c -- ; send one byte
  utrace@ 0- drop IF .">" dup .b THEN
  `io tuckc!  1 COM@ write ?ior
;
: XRECV TIMES RX overc! 1+ REPEAT drop ; \ @ # -- ; receive # bytes at @
: XSEND TIMES c@+ TX REPEAT drop ; \ @ # -- ; send # bytes starting from @

: dumbterm`  1 SKIP    \ hexa[00..1F]ascii[20..7E]hexa[7F..FF]CR[0D]LF[0A]
: dumpterm`  0 THEN >r \ hexa[00..FF]
  BEGIN normal RX ' catch 0- drop 0= IF \ (nz when key?)
    inverse r 0- IF \ dumbterm:
      $7E_ <= IF $20_ >= IF : `e drop emit AGAIN 13_ = `e ? 10_ = `e ? THEN
    THEN '\'_ emit .b AGAIN
    here dup 256 accept \ -- here n ; Lin:here+n-1:^J Win:here+n-2:^M^J
    over+ 1- [os] [IF] 13 [ELSE] 0 [THEN] swap ! \ EOL:^M^@^@^@
    BEGIN c@+ 0- WHILE \ -- @ c
      '^' CASE c@+ $40^ ELSE \ -- @ c ; "^c":control-char
      '\' CASE dup 2+ swap 1- '$' overc! 3 number \ -- @+2 n 0 ; "\xx":hexa
        0- drop IF swap 1- nipdup 1- c@ \ -- @+1 c
        13 <> drop WHILE \ -- @+1 c ; "\EOL":zapCR
        'q' = drop IF 2drop rdrop ;THEN \ "\q":quit.
      THEN      THEN    THEN TX \ -- @+1
    REPEAT 2drop \ --
  REPEAT
;
[THEN] \ 10Ksource = 2Kcode + 0.4Kheaders

\ --------------------------------------------------------------------------
\ uncomment the following line to remove all headers with initial backquote:
 hid'm  ."_hid'm"
cr ;

EOF  skips to End-Of-File, so everything after EOF is ignored.
     This may be a good place for any comment about the file.