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