\ 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` \ -- ; display help for , 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 -- ; .. 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- \ -- ; 4-:"man_" fallthru : shell \ @ # -- ; send command to shell, command result into ior zt 1 libc. system 0; ior! !"shell_call_failed" : cd` \ -- ; change directory wsparse zt 1 12 syscall ?ior ; : !!` \ -- ; 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` \ -- ; change directory wsparse zt 1 k32. SetCurrentDirectoryA 1- ?ior ; : !!` \ -- ; 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` $880F `if1 ; : =if` $850F : `if2 $DA39, s09 drop` `ifx ; : <>if` $840F `if2 ; : 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 SC here - dup -$7E SC here - dup -$7C 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 -- ; 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| 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 -- ; -- 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_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: 1TD>2 4>DTR>20 5-GND-7 6RTS>4 8TD>7 4>DTR>9 5-GND-5 6RTS>8 8TD>12 5-GND<5 3V3<15 7>RTS>13 8BLRX 2>RST 1-GND 3>TCK 3>3V \ C03kbd: 3URX1 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.