dialer/defs.jrt

87 lines
2.4 KiB
Plaintext
Executable file

: >rot <rot <rot ;
: 2dup over over ;
: 3dup >r 2dup r@ >rot <r ;
: 4dup >r >r 2dup r@ >rot rswap r@ >rot <r <r swap ;
: nip swap drop ;
: 2= ( a b c d -- a=c&b=d )
>r <rot = swap <r = and ;
: 2swap ( a b c d -- c d a b )
>r >rot <r >rot ;
: 2drop drop drop ;
: negate 0 swap - ;
: abs dup 0 < if negate then ;
: ~ -1 ^ ;
: f! ( b v flag -- )
>rot >r r@ @ >rot ( val flag b r: v )
if | else ~ & then <r ! ;
: f@ ( v flag -- b ) swap @ & ;
: fnot! ( v flag -- ) over @ ^ swap ! ;
: @! ( newval v -- oldval ) dup @ >rot ! ;
: expile state if , else execute then ;
: :noname here $DOCOLON , ] ;
: array word new-word $DOVAR , ;
: create word new-word $DOCREATE , 0 , ;
: finishcreate ( ipfirst -- )
( set cell after codepointer to first instruction of does> )
latest codepointer cell + ! ;
: does> here 4 cells + lit ' finishcreate , ' return , ] ; immediate
: +towards ( from to -- from+-1 )
over > if 1 + else 1 - then ;
: for ( from to -- )
' >r , [ ' begin , ] ( from r: to )
' dup , ' r@ , ' != , [ ' while , ]
' >r , ; immediate ( r: to from )
: i ' r@ , ; immediate
: next
' <r , ' r@ , ' +towards , ( from+1 r: to )
[ ' repeat , ] ' drop , ' rdrop , ; immediate
: breakfor
' rdrop , ' rdrop , 0 lit ' >r , 1 lit ' >r , ; immediate
: yield rswap ;
: done rdrop 0 >r rswap ;
: ;done ' done , [ ' [ , ] ; immediate
: each [ ' begin , ] ' r@ , [ ' while , ] ; immediate
: more ' yield , [ ' repeat , ] ' rdrop , ; immediate
: break rswap rdrop :| yield done |; execute rswap ;
: links begin yield @ dup not until drop ;done
: files findfile begin dup while yield nextfile repeat drop ;done
: .files files each type s" " type more ;
: min ( x y -- x|y ) 2dup > if swap then drop ;
: max ( x y -- x|y ) 2dup < if swap then drop ;
: +!pos ( n var -- ) dup @ <rot + 0 max swap ! ;
: cycle! ( var lim -- )
over @ dup 0 < if drop 1 - swap !
else <= if 0 swap !
else drop then then ;
: +!cycle ( n var lim -- ) >r >r r@ +! <r <r cycle! ;
: intern create latest wordname , does> @ ;
: lazy here $DODEFERRED , ' noop , ;
: >lazy! latest codepointer swap redefine ;
: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
: .hexnib ( x -- )
dup 0 >= over 9 <= and if [ key 0 lit ]
else 10 - [ key A lit ] then + emit ;
: .hex dup 0xf0 & 4 >> .hexnib 0x0f & .hexnib bl ;