net2o-tools.fs 1.8 KB
Newer Older
bernd's avatar
bernd committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
\ net2o tools

: ?nextarg ( -- addr u noarg-flag )
    argc @ 1 > IF  next-arg true  ELSE  false  THEN ;

[IFUNDEF] safe/string
: safe/string ( c-addr u n -- c-addr' u' )
\G protect /string against overflows.
    dup negate >r  dup 0> IF
        /string dup r> u>= IF  + 0  THEN
    ELSE
        /string dup r> u< IF  + 1+ -1  THEN
    THEN ;
[THEN]

: or!   ( x addr -- )   >r r@ @ or   r> ! ;
: xor!  ( x addr -- )   >r r@ @ xor  r> ! ;
: and!  ( x addr -- )   >r r@ @ and  r> ! ;
: min!  ( n addr -- )   >r r@ @ min  r> ! ;
: max!  ( n addr -- )   >r r@ @ max  r> ! ;
: umin! ( n addr -- )   >r r@ @ umin r> ! ;
: umax! ( n addr -- )   >r r@ @ umax r> ! ;

: xorc! ( x c-addr -- )   >r r@ c@ xor  r> c! ;
: andc! ( x c-addr -- )   >r r@ c@ and  r> c! ;
: orc!  ( x c-addr -- )   >r r@ c@ or   r> c! ;

: max!@ ( n addr -- )   >r r@ @ max r> !@ ;
: umax!@ ( n addr -- )   >r r@ @ umax r> !@ ;

\ generic stack using string array primitives

: stack> ( stack -- x ) >r
    \g generic single-stack pop
35
    r@ $[]# dup 0<= !!stack-empty!!
bernd's avatar
bernd committed
36 37 38 39 40
    1- dup r@ $[] @ swap cells r> $!len ;
: >stack ( x stack -- )
    \g generic single-stack push
    dup $[]# swap $[] ! ;

41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
: stack@ ( stack -- x1 .. xn n )
    \g fetch everything from the generic stack to the data stack
    $@ dup cell/ >r bounds ?DO  I @  cell +LOOP  r> ;
: stack! ( x1 .. xn n stack -- )
    \g set the generic stack with values from the data stack
    >r cells r@ $!len
    r> $@ bounds cell- swap cell- -DO  I !  cell -LOOP ;

: ustack ( "name" -- )
    \g generate user stack, including initialization and free on thread
    \g start and termination
    User  latestxt >r
    :noname  action-of thread-init compile,
    r@ compile, postpone off postpone ;
    is thread-init
    :noname  action-of kill-task  compile,
    r> compile, postpone $off postpone ;
    is kill-task ;