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

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