83 lines
2.1 KiB
Plaintext
Executable file
83 lines
2.1 KiB
Plaintext
Executable file
: 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| $DOCOLON , ; immediate
|
|
: |; ' ret , |inline ; immediate
|
|
|
|
: defer word new-word $DOCOLON , ' noop , ' ret , ;
|
|
: redefine ( cp cpdeferred ) cell + ! ;
|
|
|
|
: 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> , 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 ! ;
|
|
|