pete286/defs.jor

: stdout ' putc task-emit ! ;
s" jorth.log" open seekend deactivate const LOGFILE
: withfp ( xt fp -- ) fdeactivate r> factivate execute fdeactivate drop r< factivate ;
: log-emit ' fputc LOGFILE withfp ;

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

: noop ;

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

: :| inline| :noname ; immediate
: |; ' ret , |inline ; immediate

: defer word new-word docolon , ' noop , ' ret , ;
: redefine ( cp cpdeferred ) cell + ! ;

: +towards ( from to -- from+-1 )
  over > if 1 + else 1 - then ;

: for ( from to -- ) ' r> , here ' r> , ; immediate ( r: to from )
: i ' r@ , ; immediate
: next ' r< , ' r@ , ' +towards , ( from+1 r: to )
       ' dup , ' r@ , ' = , ' BZ_ , ,
       ' rdrop , ' drop , ; immediate

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

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

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

: 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

: send ( val task -- )
  mailbox
  begin dup @ while suspend repeat ( wait for empty mailbox )
  ! ;

: receive ( -- val )
  running mailbox
  begin dup @ not while suspend repeat ( wait for mail )
  dup @ 0 <rot ! ;