\ ondo  2001/8/23 KDJ
\ Provides ON:..DO: construct.

\ Copyright 2001
\ Kristopher D. Johnson
\ 
\ THIS SOFTWARE IS PROVIDED "AS IS"
\ WITHOUT WARRANTY OF ANY KIND.
\ THE AUTHOR SHALL NOT BE LIABLE
\ FOR ANY CLAIM IN CONNECTION
\ WITH THIS CODE.
\ 
\ This software may be used, copied,
\ modified, or distributed for any
\ purpose, provided that the above
\ copyright notice and disclaimer of
\ warranty is retained on all copies.

\ "on: VALUE do: WORD" is equivalent
\ to "dup VALUE = if WORD exit then"
\
\ Any number of "or: WORD" phrases
\ may appear between ON: and DO:.
\ These will be evaluated in short-
\ circuit fashion: the first that
\ matches the top-of-stack value will
\ branch immediately to DO:
\ 
\ Typical use:
\ 
\ needs Events
\ needs ondo
\ 
\ : DoCtlSelect ( -- ) ... ;
\ : DoMenu ( -- ) ... ;
\ : DoPenDown ( -- ) ... ;
\ 
\ : dispatch-event ( ekey -- ekey )
\   on: ctlSelectEvent do: DoCtlSelect
\   on: menuEvent do: DoMenu
\   on: penDownEvent do: DoPenDown ;
\ 
\ : event-loop ( -- )
\   begin
\     ekey dispatch-event drop
\   again ;
\
\ Relies upon undocumented features
\ of Quartus Forth 1.2.x; may not
\ be compatible with future releases.

needs condthens

\ M68K opcodes
(hex) be7c constant cmp#,tos
(hex) 6600 constant bne.w
(hex) 6700 constant beq.w

\ Compile conditional branch,
\ leaving ORIG on stack for later
\ resolution by ELSE or THEN
: (bcc-orig) ( op -- ) ( C: -- orig )
  cs, cshere 0 cs, ;

: (eval-word) ( "word" -- i**x )
  parse-word evaluate ;

: (on:) ( x "word" -- x )
  cmp#,tos cs,
  postpone [ (eval-word) postpone ]
  cs, ;

\ Compare top-of-stack with
\ value of following word
: on: ( x "word" -- x )
  postpone cond
  (on:)
; immediate

\ If EQ, branch ahead to DO:,
\ else compare TOS with neot word
: or: ( x "word" -- x )
  beq.w (bcc-orig)
  (on:)
; immediate

\ If EQ, jump to NAME, otherwise
\ branch over NAME
: do: ( "name" -- )
  bne.w (bcc-orig) >r
  postpone thens
  (eval-word)
  postpone exit
  r> postpone then
; immediate

