git.gag.com Git - debian/pforth/blob - fth/case.fth

   1 \ @(#) case.fth 98/01/26 1.2
   2 \ CASE Statement
   3 \
   4 \ This definition is based upon Wil Baden's assertion that
   5 \ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc.
   6 \
   7 \ Author: Phil Burk
   8 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
   9 \
  10 \ The pForth software code is dedicated to the public domain,
  11 \ and any third party may reproduce, distribute and modify
  12 \ the pForth software code or any derivative works thereof
  13 \ without any compensation or license.  The pForth software
  14 \ code is provided on an "as is" basis without any warranty
  15 \ of any kind, including, without limitation, the implied
  16 \ warranties of merchantability and fitness for a particular
  17 \ purpose and their equivalents under the laws of any jurisdiction.
  18 \
  19 \ MOD: PLB 6/24/91 Check for missing ENDOF
  20 \ MOD: PLB 8/7/91 Add ?OF and RANGEOF
  21 \ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth.
  22
  23 anew TASK-CASE
  24
  25 variable CASE-DEPTH
  26 variable OF-DEPTH
  27
  28 : CASE  ( n -- , start case statement ) ( -c- case-depth )
  29     ?comp
  30     of-depth @   0 of-depth !   \ 11/2/99
  31     case-depth @ 0 case-depth !  ( allow nesting )
  32 ; IMMEDIATE
  33
  34 : ?OF  ( n flag -- | n , doit if true ) ( -c- addr )
  35     [compile] IF
  36     compile drop
  37     1 case-depth +!
  38     1 of-depth +!
  39 ; IMMEDIATE
  40
  41 : OF  ( n t -- | n , doit if match ) ( -c- addr )
  42     ?comp
  43     compile over compile =
  44     [compile] ?OF
  45 ; IMMEDIATE
  46
  47 : (RANGEOF?)  ( n lo hi -- | n  flag )
  48     >r over ( n lo n ) <=
  49     IF
  50         dup r> ( n n hi ) <=
  51     ELSE
  52         rdrop false
  53     THEN
  54 ;
  55
  56 : RANGEOF  ( n lo hi -- | n , doit if within ) ( -c- addr )
  57     compile (rangeof?)
  58     [compile] ?OF
  59 ; IMMEDIATE
  60
  61 : ENDOF  ( -- ) ( addr -c- addr' )
  62     [compile] ELSE
  63     -1 of-depth +!
  64 ; IMMEDIATE
  65
  66 : ENDCASE ( n -- )  ( old-case-depth addr' addr' ??? -- )
  67     of-depth @
  68     IF >newline ." Missing ENDOF in CASE!" cr abort
  69     THEN
  70 \
  71     compile drop
  72     case-depth @ 0
  73     ?DO [compile] THEN
  74     LOOP
  75     case-depth !
  76     of-depth !
  77 ; IMMEDIATE
  78