Unnamed

: off  false swap ! ;
: on   true swap ! ;

: semaphore ( -- semaphore )  align here 0 , ;
: semaphore: ( "name" -- )  semaphore constant ;

: new-semanode ( xt semaphore -- )
  align here  swap dup @ ( link ) , !   true ( status ) ,  ( xt ) , ;

: semanode-status ( semanode -- semanode-sfa )  cell+ ;
: semanode-xt ( semanode -- xt )  2 cells + @ ;
: ?semanode-active ( semanode -- flag )  semanode-status @ ;
: perform-semanode ( semanode -- )  semanode-xt execute ;

: find-semanode ( xt semaphore -- semanode true | false )
  begin @ dup while
    2dup semanode-xt <> while
  repeat  nip true 
  else    2drop false  then ;

: +semaphore ( xt semaphore -- )
  2dup find-semanode if  semanode-status on  2drop  else  new-semanode  then ;

: -semaphore ( xt semaphore -- )  find-semanode if  semanode-status off  then ;

: >semaphore ( semaphore -- )
  dup  begin @ dup while
    dup ?semanode-active if  2dup perform-semanode  then
  repeat  2drop ;


semaphore: test
.( Created semaphore 'test': ) test . cr

.( Sending semaphore...) cr
test >semaphore cr

: A ." A received: " . ;
: B ." B received: " . ;
: C ." C received: " . ;

.( Adding A. )
' A test +semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Adding B. )
' B test +semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Adding B again. )
' B test +semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Adding C. )
' C test +semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Removing A. )
' A test -semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Removing A again. )
' A test -semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Removing C. )
' C test -semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Removing B again. )
' B test -semaphore
.( Sending semaphore...) cr
test >semaphore cr

.( Done.) cr