173 lines
4.3 KiB
Plaintext
Executable file
173 lines
4.3 KiB
Plaintext
Executable file
: stdout ' putc task-emit ! ;
|
|
|
|
: >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 ;
|
|
|
|
: 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 ! ;
|
|
|
|
: userword 1 latest wordflags F_USERWORD f! ;
|
|
|
|
: expile state if , else execute then ;
|
|
|
|
: :noname here $DOCOLON , ] ;
|
|
|
|
: withfp ( xt fp -- ) :| factivate execute fdeactivate drop |; preservefp ;
|
|
|
|
: 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 , ' ret , ] ; 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! ( lim var -- )
|
|
>r dup r@ @ <= if
|
|
drop 0 r@ !
|
|
else r@ @ 0 < if
|
|
r@ !
|
|
else drop then then rdrop ;
|
|
|
|
: +!cycle ( n var lim -- )
|
|
>r >r r@ +! <r <r swap cycle! ;
|
|
|
|
over > if drop 0 else dup 0 <
|
|
: checkpoint ( cp -- )
|
|
create here 4 cells + , latest , tasks , ,
|
|
does> dup @ here!
|
|
dup cell + @ latest!
|
|
dup 2 cells + @ tasks!
|
|
3 cells + @ execute ;
|
|
|
|
: intern create latest wordname , does> @ ;
|
|
|
|
: preserving ( cp 0 vars... -- )
|
|
0 >r begin dup while dup @ >r >r repeat drop
|
|
execute
|
|
begin r@ while <r <r swap ! repeat rdrop ;
|
|
: preserve ( cp var -- ) 0 swap preserves ;
|
|
|
|
|
|
: decompile
|
|
word lookup if 1 begin ( cp i )
|
|
2dup cells + @ ( cp i @cp+i )
|
|
dup ' ret != ( cp i @cp+i bool )
|
|
while
|
|
dup ` dup if type drop else drop . then bl ( cp i )
|
|
1 + ( cp i+1 )
|
|
repeat drop drop then drop ; userword
|
|
|
|
: words
|
|
latest links each
|
|
dup wordflags F_USERWORD f@ if
|
|
dup wordname type bl
|
|
then
|
|
more ;
|
|
|
|
: lazy here $DODEFERRED , ' noop , ;
|
|
: >lazy! latest codepointer swap redefine ;
|
|
|
|
: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
|
|
|
|
( tasks )
|
|
: mailbox 2 cells + ;
|
|
: task-ip task-user-size cells + ;
|
|
: task-sp task-user-size 1 + cells + ;
|
|
: task-rsp task-user-size 2 + cells + ;
|
|
: task-stack task-user-size 3 + cells + ;
|
|
: task-rstack task-stack stacksize cells + ;
|
|
|
|
: .wordin ( ptr -- )
|
|
latest links each
|
|
2dup > if wordname type drop 0 break then
|
|
more dup if . else drop then ; userword
|
|
|
|
: tasks.s
|
|
tasks links each
|
|
dup .wordin s" : " type
|
|
dup task-sp @ over task-stack ( task stackLim stack )
|
|
begin 2dup > while dup @ . cell + repeat
|
|
cr drop drop more ; userword
|
|
|
|
: doactivate ( task ip -- )
|
|
over task-ip !
|
|
dup task-stack over task-sp !
|
|
dup task-rstack over task-rsp !
|
|
drop
|
|
;
|
|
|
|
: activate
|
|
here 4 cells + lit
|
|
' doactivate ,
|
|
' ret ,
|
|
; immediate
|
|
|
|
: >task ( val task -- )
|
|
task-sp >r r@ @ ! r@ @ cell + r> ! ;
|
|
|
|
: try-send ( val task -- b )
|
|
mailbox dup @ if drop drop 0 else ! 1 then ;
|
|
|
|
: wait-send ( val task -- )
|
|
mailbox
|
|
begin dup @ while suspend repeat ( wait for empty mailbox )
|
|
! ;
|
|
|
|
: send ( val task -- ) try-send drop ;
|
|
|
|
: receive ( -- val )
|
|
running mailbox
|
|
begin dup @ not while suspend repeat ( wait for mail )
|
|
dup @ 0 <rot ! ;
|
|
|