1 line
8.0 KiB
Plaintext
1 line
8.0 KiB
Plaintext
\ Miser's Case Extend CASE with Pascal and C style features COND OF ELSE THENS (in DX-Forth kernel) COND EQUAL RANGE WHEN CONTINUE IF See demo screen for usage \ Miser's Case forth definitions decimal cr .( loading Miser's Case ) 2 5 thru \ .( loading Case demo ) 6 load \ Miser's Case application 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 \ Miser's Case system \ Wil Baden's COND THENS (now in DX-FORTH kernel) \ : COND \ cs-mark ; immediate \ : THENS \ begin cs-test while postpone then repeat cs-drop ; \ immediate \ Add Pascal-like features : EQUAL postpone (equ) >mark ; immediate : RANGE postpone (rng) >mark ; immediate \ Miser's Case : WHEN postpone else cs-push postpone thens cs-pop ; immediate \ Add C Switch flow-through : CONTINUE cs-push postpone thens postpone cond cs-pop ; immediate application \ Miser's Case behead (equ) (rng) \ Case demo : test ( n ) space cond [ hex ] cond 0 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 " [ decimal ] thens ; --> \ Case demo cr cr .( [press any key] ) key drop cr cr .( Miser's CASE demo ...) cr cr char a .( ) dup emit test cr char , .( ) dup emit test cr char 8 .( ) dup emit test cr char ? .( ) dup emit test cr char K .( ) dup emit test cr 0 dup 3 .r test cr 127 dup 3 .r test cr 128 dup 3 .r test |