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 \ Permission to use, copy, modify, and/or distribute this
  11 \ software for any purpose with or without fee is hereby granted.
  12 \
  13 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  14 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  15 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  16 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  17 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  18 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  19 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21 \
  22 \ MOD: PLB 6/24/91 Check for missing ENDOF
  23 \ MOD: PLB 8/7/91 Add ?OF and RANGEOF
  24 \ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth.
  25
  26 anew TASK-CASE
  27
  28 variable CASE-DEPTH
  29 variable OF-DEPTH
  30
  31 : CASE  ( n -- , start case statement ) ( -c- case-depth )
  32     ?comp
  33     of-depth @   0 of-depth !   \ 11/2/99
  34     case-depth @ 0 case-depth !  ( allow nesting )
  35 ; IMMEDIATE
  36
  37 : ?OF  ( n flag -- | n , doit if true ) ( -c- addr )
  38     [compile] IF
  39     compile drop
  40     1 case-depth +!
  41     1 of-depth +!
  42 ; IMMEDIATE
  43
  44 : OF  ( n t -- | n , doit if match ) ( -c- addr )
  45     ?comp
  46     compile over compile =
  47     [compile] ?OF
  48 ; IMMEDIATE
  49
  50 : (RANGEOF?)  ( n lo hi -- | n  flag )
  51     >r over ( n lo n ) <=
  52     IF
  53         dup r> ( n n hi ) <=
  54     ELSE
  55         rdrop false
  56     THEN
  57 ;
  58
  59 : RANGEOF  ( n lo hi -- | n , doit if within ) ( -c- addr )
  60     compile (rangeof?)
  61     [compile] ?OF
  62 ; IMMEDIATE
  63
  64 : ENDOF  ( -- ) ( addr -c- addr' )
  65     [compile] ELSE
  66     -1 of-depth +!
  67 ; IMMEDIATE
  68
  69 : ENDCASE ( n -- )  ( old-case-depth addr' addr' ??? -- )
  70     of-depth @
  71     IF >newline ." Missing ENDOF in CASE!" cr abort
  72     THEN
  73 \
  74     compile drop
  75     case-depth @ 0
  76     ?DO [compile] THEN
  77     LOOP
  78     case-depth !
  79     of-depth !
  80 ; IMMEDIATE
  81