\ Eaker's CASE with extensions to make it a general control structure \ This file is in the public domain. NO WARRANTY. \ Dependencies: Assumes control-flow stack items are at least \ partially on the data stack \ compatibility stuff [undefined] compile-only [if] : compile-only ; [then] [undefined] cs-drop [if] : cs-drop postpone ahead 1 cs-roll postpone again postpone then ; [then] [undefined] \g [if] : \g source >in ! drop ; immediate [then] \ a case-sys is: old-case-depth orig1 ... orign dest variable case-depth \ contains the stack depth after old-case-depth was pushed : case ( compilation -- case-sys ; run-time -- ) \ core-ext \g Start a @code{case} structure. case-depth @ depth case-depth ! postpone begin ; immediate compile-only : ?of ( compilation -- of-sys ; run-time f -- ) \ gforth question-of \g If f is true, continue; otherwise, jump behind @code{endof} or \g @code{contof}. POSTPONE IF ; immediate compile-only : of ( compilation -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext \g If x1=x2, continue (dropping both); otherwise, leave x1 on the \g stack and jump behind @code{endof} or @code{contof}. postpone over postpone = postpone ?of postpone drop ; immediate compile-only : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ core-ext end-of \g Exit the enclosing @code{case} structure by jumping behind \g @code{endcase}/@code{next-case}. postpone else 1 cs-roll ; immediate compile-only : contof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ gforth cont-of \g Restart the @code{case} loop by jumping to the enclosing \g @code{case}. 1 cs-pick postpone again postpone then ; immediate compile-only : closecase ( old-case-depth orig1 ... orign -- ) begin depth case-depth @ > while postpone then repeat case-depth ! ; : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case \g Finish the @code{case} structure; drop x, and continue behind \g the @code{endcase}. Dropping x is useful in the original \g @code{case} construct (with only @code{of}s), but you may have \g to supply an x in other cases (especially when using \g @code{?of}). postpone drop cs-drop closecase ; immediate compile-only : next-case ( compilation case-sys -- ; run-time -- ) \ gforth \g Restart the @code{case} loop by jumping to the matching \g @code{case}. Note that @code{next-case} does not drop a cell, \g unlike @code{endcase}. postpone again closecase ; immediate compile-only