pete286/defs.jor

: stdout ' putc task-emit ! ;
: withfp ( xt fp -- ) fdeactivate r> factivate execute fdeactivate drop r< factivate ;

: >rot <rot <rot ;
: 2dup over over ;
: 3dup r> 2dup r@ >rot r< ;
: 4dup r> r> 2dup r@ >rot rswap r@ >rot r< r< swap ;

: 2= ( a b c d -- a=c&b=d )
  r> <rot = swap r< = and ;

: ~ -1 ^ ;
: f! ( b v flag -- )
  r> dup @ ( b v val r: flag )
  <rot if r< | else r< ~ & then ( v newval )
  swap ! ;
: f@ ( v flag -- ) swap @ & ;
: fnot! 2dup f@ not f! ;

: expile state if , else execute then ;

' cells @ const $DOCOLON ( get the colon execution token )
: :noname here $DOCOLON , ] ;

: :| inline| $DOCOLON , ; immediate
: |; ' ret , |inline ; immediate

: 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

: yield rswap ;
: each [ ' begin , ] ' dup , [ ' while , ] ; immediate
: more ' yield , [ ' repeat , ] ' drop , ] ; immediate
: dobreak yield 0 ;
: break ' rdrop , ' dobreak , ; immediate

: links begin yield @ dup not until ;

( usage:
  : search-xy { x y -- b r: coroutine } begin 2dup search >rot drop drop ;
  : test-xy { x y -- b }
    search-xy 1 2 2= yield 3 4 2= yield drop drop 999 yield ;
  test-xy will return 1 if x y is 1 2 or 3 4, otherwise it returns 999.
  Note that it must always end with a yield, as search has no way to tell
  the difference between an early termination and a final non-zero result.
)
: search
  ' yield , ' dup , ' not , [ ' while , ] ' drop , [ ' repeat , ]
  ' rdrop , ; immediate

: min ( x y -- x|y ) 2dup > if swap then drop ;
: max ( x y -- x|y ) 2dup < if swap then drop ;

: 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> @ ;

: 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 ;

: words latest links each dup wordname type bl more ;

( 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 ;

: 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 ;

: 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

: 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 ! ;