neuttower/defs.jor

: 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-from ( ip -- )
  begin dup @ ' ret != while
    dup @ dup ` dup if type drop else drop . then bl
    cell +
  repeat drop ;

: decompile word lookup if cell + decompile-from else drop then ; 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

: task.bt ( task -- )
  dup task-rsp @ swap task-rstack ( rstackLim rstack )
  begin 2dup > while dup @ dup . .wordin cr cell + repeat
  drop drop ; 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 ! ;