Revision 2014-03-08
This Case statement offers the following features:
It is called Miser's Case because it immodestly claims to 'do everything yet cost nothing'.
Implementation
The following high-level implementation is intended as a guide
only. Two custom
implementations are provided. [See also
CFS extensions for a portable version.]
\ Miser's Case \ \ A general purpose Forth case statement. \ \ Revision 2014-03-08 \ \ ------------------------------------------------------------- \ History \ - RANGE changed to use BETWEEN. \ Add CONTINUE for C-style switching. \ - Examples revised. Minor text changes. \ - Add THENS END-CASE. \ - EQUAL RANGE re-coded for optimizers. \ - Text and example re-worded to emphasize use of \ COND THENS while deprecating Forth-94 CASE. \ - Add custom implementations \ ------------------------------------------------------------- \ \ Sample implementation only \ \ The high-level implementation makes assumptions about the \ control flow stack which may not be applicable to your forth: \ control flow is on the data stack; control flow items are 1, \ 2 or 3 cells wide; the number 0 (single cell) is used as a \ sentinel. \ \ For all but the best optimizing Forth compilers, the run-time \ should be replaced with machine-code primitives for maximum \ performance. \ \ COND THENS is per Wil Baden and provides the mechanism for \ resolving nested conditionals. \ \ Tested on SwiftForth, VFX, Win32Forth, Gforth and others. \ \ This code is public domain. Use at your own risk. \ \ Keywords: \ \ COND OF IF ELSE THENS CONTINUE EQUAL RANGE WHEN \ \ Syntax: \ \ COND ( x1) \ x2 OF ... ELSE \ COND <tests> WHEN ... ELSE \ <test> IF ( DROP) ... ELSE \ ( x1) ( DROP) ... ( default ) \ THENS \ \ COND ... THENS is analogous to CASE ... ENDCASE with \ the exception that THENS does not automatically DROP x1. \ \ OF performs the same function as the Forth-94 word but \ in addition may be used with ELSE or THEN. ( x1) x2 OF \ is the short-form of ( x1) COND x2 EQUAL WHEN. \ \ COND <tests> WHEN where <tests> may consist of one or \ more of the following: \ \ x2 EQUAL ( test if x1 equals x2 ) \ x2 x3 RANGE ( test if x1 is in the range x2..x3 ) \ \ Miser's COND ... WHEN generates compact efficient code \ comparable with other language compilers. \ \ <test> IF where <test> can be any code which leaves x1 \ and a flag for IF. IF ... ELSE is for expansion allowing \ user-defined tests including those where x1 is not \ necessarily an integer. \ \ CONTINUE redirects program flow from previously matched \ tests that would otherwise pass to THENS. It provides a \ 'fall-through' capability akin to C's switch statement. \ CONTINUE may be placed anywhere within: \ \ OF ... ELSE \ WHEN ... ELSE \ IF ( DROP) ... ELSE \ 0 constant COND immediate : THENS begin ?dup while postpone then repeat ; immediate cr .( Are you using SwiftForth or VFX? Y/N ) key dup emit cr dup char Y = swap char y = or [if] : WHEN postpone else >r postpone thens r> postpone drop ; immediate : CONTINUE >r postpone thens postpone cond r> ; immediate [else] cr .( Are you using gForth Y/N ) key dup emit cr dup char Y = swap char y = or [if] : WHEN postpone else >r >r >r thens r> r> r> postpone drop ; immediate : CONTINUE >r >r >r postpone thens postpone cond r> r> r> ; immediate [else] : WHEN postpone else 2>r postpone thens 2r> postpone drop ; immediate : CONTINUE 2>r postpone thens postpone cond 2r> ; immediate [then] [then] : EQUAL postpone over postpone <> postpone if ; immediate \ RANGE is based on : BETWEEN OVER - -ROT - U< 0= ; \ Values may be signed or unsigned. : (range) 2 pick -rot over - -rot - u< ; : RANGE postpone (range) postpone if ; immediate : OF postpone over postpone = postpone if postpone drop ; immediate \ Forth-94 compatibility words : CASE postpone cond ; immediate : ENDOF postpone else ; immediate : ENDCASE postpone drop postpone thens ; immediate
\ Using VFX 4.02 for Windows the following code compiles
\ to 69 instructions using Miser's Case, compared with 131
\ instructions for an equivalent FORTH-94 based CASE.
hex
: TEST1 ( n ) space
cond
cond
00 1F range
7F equal when ." Control char " else
cond
20 2F range
3A 40 range
5B 60 range
7B 7E range when ." Punctuation " else
cond 30 39 range when ." Digit " else
cond 41 5A range when ." Upper case letter " else
cond 61 7A range when ." Lower case letter " else
drop ." Not a character "
thens ;
decimal
cr cr .( Running TEST...)
cr char a .( ) dup emit test1
cr char , .( ) dup emit test1
cr char 8 .( ) dup emit test1
cr char ? .( ) dup emit test1
cr char K .( ) dup emit test1
cr 0 dup 3 .r test1
cr 127 dup 3 .r test1
cr 128 dup 3 .r test1
\ end
Note: For systems which do not accept the sequence OF ... ELSE ... THEN it will be
necessary to redefine OF. In such cases it may also be necessary
to redefine CASE ENDOF
ENDCASE as previously described.
1. 80x86 32-bit native code
\ Miser's Case for SwiftForth
ONLY FORTH ALSO DEFINITIONS DECIMAL
AKA CASE COND IMMEDIATE
: THENS
BEGIN ?DUP WHILE POSTPONE THEN REPEAT -BAL ; IMMEDIATE
ICODE (EQU)
0 [EBP] EBX CMP 0= IF
4 [EBP] EBX MOV 8 # EBP ADD HERE $400 + JMP
THEN RET
END-CODE
ICODE (RNG)
0 [EBP] EBX SUB 4 [EBP] EDX MOV 0 [EBP] EDX SUB
EDX EBX CMP U>= IF
8 [EBP] EBX MOV 12 # EBP ADD HERE $400 + JMP
THEN RET
END-CODE
: EQUAL POSTPONE (EQU) HERE +BAL POSTPONE DROP ; IMMEDIATE
: RANGE POSTPONE (RNG) HERE +BAL POSTPONE 2DROP ; IMMEDIATE
: WHEN
POSTPONE ELSE >R POSTPONE THENS R> ; IMMEDIATE
: CONTINUE
>R POSTPONE THENS POSTPONE COND R> ; IMMEDIATE
2. 8086 16-bit DTC
\ Miser's Case for DX-Forth code (of) bx pop ax pop bx ax cmp 1 $ jz ax push 0 [si] si mov next 1 $: 2 # si add next end-code code (equ) bx pop ax pop ax bx cmp 1 $ jz ax push 2 # si add next 1 $: 0 [si] si mov next end-code code (rng) bx pop dx pop ax pop ax cx mov dx cx sub dx bx sub bx cx cmp 1 $ jna ax push 2 # si add next 1 $: 0 [si] si mov next end-code 0 constant COND immediate : THENS begin ?dup while postpone then repeat ; immediate : OF postpone (of) >mark ; immediate : EQUAL postpone (equ) >mark ; immediate : RANGE postpone (rng) >mark ; immediate : WHEN postpone else >r postpone thens r> ; immediate : CONTINUE >r postpone thens postpone cond r> ; immediate
Miser's Case extension for DX-Forth is
provided in the distribution.
Page updated: 2014-03-08