commit 14a2a38c5247dd571ff4bb68491008f085cb86fe
parent 64fe1f05c2f3c3f5bb2bd94d993f909fd8a20a88
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Mon, 27 Apr 2026 10:57:51 -0700
scheme1: when, unless, case
Diffstat:
7 files changed, 351 insertions(+), 112 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -1163,6 +1163,9 @@
%dispatch_form(&sym_letrec, &::do_letrec)
%dispatch_form(&sym_and, &::do_and)
%dispatch_form(&sym_or, &::do_or)
+ %dispatch_form(&sym_when, &::do_when)
+ %dispatch_form(&sym_unless, &::do_unless)
+ %dispatch_form(&sym_case, &::do_case)
%dispatch_form(&sym_setbang, &::do_setbang)
%dispatch_form(&sym_define_record_type, &::do_define_record_type)
%dispatch_form(&sym_pmatch, &::do_pmatch)
@@ -1212,6 +1215,12 @@
%tail_to_handler(&eval_and)
::do_or
%tail_to_handler(&eval_or)
+ ::do_when
+ %tail_to_handler(&eval_when)
+ ::do_unless
+ %tail_to_handler(&eval_unless)
+ ::do_case
+ %tail_to_handler(&eval_case)
::do_setbang
%tail_to_handler(&eval_setbang)
::do_define_record_type
@@ -1351,6 +1360,9 @@
%intern_form(&name_letrec, 6, &sym_letrec)
%intern_form(&name_and, 3, &sym_and)
%intern_form(&name_or, 2, &sym_or)
+ %intern_form(&name_when, 4, &sym_when)
+ %intern_form(&name_unless, 6, &sym_unless)
+ %intern_form(&name_case, 4, &sym_case)
%intern_form(&name_setbang, 4, &sym_setbang)
%intern_form(&name_define_record_type, 18, &sym_define_record_type)
%intern_form(&name_pmatch, 6, &sym_pmatch)
@@ -1894,6 +1906,131 @@
%mov(a0, t0)
})
+# eval_when(rest=a0, env=a1) -> value (a0).
+# (when test body...) -- if test evaluates non-#f, tail-eval body and
+# return its last value; otherwise return UNSPEC. Body never enters a
+# new scope.
+#
+# Locals:
+# rest
+# env
+%fn2(eval_when, {rest env}, {
+ %stl(a0, rest)
+ %stl(a1, env)
+
+ %car(a0, a0) ; test
+ %call(&eval)
+
+ %li(t0, %imm_val(%IMM.FALSE))
+ %beq(a0, t0, &::skip)
+
+ %ldl(a0, rest)
+ %cdr(a0, a0) ; body
+ %ldl(a1, env)
+ %tail(&eval_body)
+
+ ::skip
+ %li(a0, %imm_val(%IMM.UNSPEC))
+})
+
+# eval_unless(rest=a0, env=a1) -> value (a0).
+# Mirror of eval_when: tail-eval body iff test is #f, else UNSPEC.
+#
+# Locals:
+# rest
+# env
+%fn2(eval_unless, {rest env}, {
+ %stl(a0, rest)
+ %stl(a1, env)
+
+ %car(a0, a0) ; test
+ %call(&eval)
+
+ %li(t0, %imm_val(%IMM.FALSE))
+ %bne(a0, t0, &::skip)
+
+ %ldl(a0, rest)
+ %cdr(a0, a0) ; body
+ %ldl(a1, env)
+ %tail(&eval_body)
+
+ ::skip
+ %li(a0, %imm_val(%IMM.UNSPEC))
+})
+
+# eval_case(rest=a0, env=a1) -> value (a0).
+# rest is (key-expr clause...). The key is evaluated once; clauses are
+# tried in order. Clause shape:
+# ((datum...) body...) ; datums are literal, eq?-compared to key
+# (else body...) ; matches unconditionally
+# Matching uses pointer equality (eq?), which is correct for fixnums,
+# symbols, chars, and booleans -- the values case is meant for. The
+# matched clause's body is tail-evaluated via eval_body. No-match (and
+# no else) returns UNSPEC, mirroring eval_cond's no-match policy.
+#
+# Locals:
+# subject (evaluated key)
+# env
+# clauses (advances)
+# datums (advances within a clause)
+%fn2(eval_case, {subject env clauses datums}, {
+ %stl(a1, env)
+
+ # subject = eval(car(rest), env); clauses = cdr(rest).
+ %mov(t0, a0)
+ %cdr(t1, t0)
+ %stl(t1, clauses)
+ %car(a0, t0)
+ %ldl(a1, env)
+ %call(&eval)
+ %stl(a0, subject)
+
+ ::loop
+ %ldl(t0, clauses)
+ %if_nil(t1, t0, &::no_match)
+
+ %car(t1, t0) ; clause
+ %car(t2, t1) ; head: datum-list or `else`
+
+ %ld_global(a3, &sym_else)
+ %beq(t2, a3, &::do_else)
+
+ # Walk the datum list, eq?-compare each against subject.
+ %stl(t2, datums)
+ %ldl(a0, subject)
+ ::scan
+ %ldl(t0, datums)
+ %if_nil(t1, t0, &::next_clause)
+ %car(t1, t0) ; datum
+ %beq(t1, a0, &::do_body)
+ %cdr(t0, t0)
+ %stl(t0, datums)
+ %b(&::scan)
+
+ ::do_body
+ %ldl(t0, clauses)
+ %car(t0, t0)
+ %cdr(a0, t0) ; body
+ %ldl(a1, env)
+ %tail(&eval_body)
+
+ ::do_else
+ %ldl(t0, clauses)
+ %car(t0, t0)
+ %cdr(a0, t0) ; body
+ %ldl(a1, env)
+ %tail(&eval_body)
+
+ ::next_clause
+ %ldl(t0, clauses)
+ %cdr(t0, t0)
+ %stl(t0, clauses)
+ %b(&::loop)
+
+ ::no_match
+ %li(a0, %imm_val(%IMM.UNSPEC))
+})
+
# eval_pmatch(rest=a0, env=a1) -> value (a0).
# rest is (subject-expr . clauses). The subject is evaluated once; each
# clause is then tried in order against the same subject value, restarting
@@ -4968,118 +5105,118 @@
# Surface names. Length is hard-coded at the call site; no NUL needed
# because intern takes (ptr, len). Aligned padding via "\0" bytes is
# fine -- M0 emits ASCII verbatim.
-:name_quote "quote"
-:name_if "if"
-:name_lambda "lambda"
-:name_define "define"
-:name_begin "begin"
-:name_cond "cond"
-:name_else "else"
-:name_arrow "=>"
-:name_let "let"
-:name_letstar "let*"
-:name_letrec "letrec"
-:name_and "and"
-:name_or "or"
-:name_setbang "set!"
-:name_define_record_type "define-record-type"
-:name_pmatch "pmatch"
+:name_quote "quote" 00 00
+:name_if "if" 00 00 00 00 00
+:name_lambda "lambda" 00
+:name_define "define" 00
+:name_begin "begin" 00 00
+:name_cond "cond" 00 00 00
+:name_else "else" 00 00 00
+:name_arrow "=>" 00 00 00 00 00
+:name_let "let" 00 00 00 00
+:name_letstar "let*" 00 00 00
+:name_letrec "letrec" 00
+:name_and "and" 00 00 00 00
+:name_or "or" 00 00 00 00 00
+:name_when "when" 00 00 00
+:name_unless "unless" 00
+:name_case "case" 00 00 00
+:name_setbang "set!" 00 00 00
+:name_define_record_type "define-record-type" 00 00 00 00 00
+:name_pmatch "pmatch" 00
:name_unquote "unquote"
-:name_guard "guard"
-:name_underscore "_"
+:name_guard "guard" 00 00
+:name_underscore "_" 00 00 00 00 00 00
# Primitive surface names.
-:name_sys_exit "sys-exit"
-:name_cons "cons"
-:name_car "car"
-:name_cdr "cdr"
-:name_nullq "null?"
-:name_pairq "pair?"
+:name_sys_exit "sys-exit" 00 00 00 00 00 00 00
+:name_cons "cons" 00 00 00
+:name_car "car" 00 00 00 00
+:name_cdr "cdr" 00 00 00 00
+:name_nullq "null?" 00 00
+:name_pairq "pair?" 00 00
:name_stringq "string?"
-:name_set_car "set-car!"
-:name_set_cdr "set-cdr!"
-:name_length "length"
-:name_list_ref "list-ref"
-:name_str_to_sym "string->symbol"
-:name_sym_to_str "symbol->string"
-:name_num_to_str "number->string"
-:name_str_to_num "string->number"
-:name_bv_append "bytevector-append"
-:name_booleanq "boolean?"
-:name_integerq "integer?"
+:name_set_car "set-car!" 00 00 00 00 00 00 00
+:name_set_cdr "set-cdr!" 00 00 00 00 00 00 00
+:name_length "length" 00
+:name_list_ref "list-ref" 00 00 00 00 00 00 00
+:name_str_to_sym "string->symbol" 00
+:name_sym_to_str "symbol->string" 00
+:name_num_to_str "number->string" 00
+:name_str_to_num "string->number" 00
+:name_bv_append "bytevector-append" 00 00 00 00 00 00
+:name_booleanq "boolean?" 00 00 00 00 00 00 00
+:name_integerq "integer?" 00 00 00 00 00 00 00
:name_symbolq "symbol?"
-:name_procedureq "procedure?"
-:name_zeroq "zero?"
-:name_not "not"
-:name_eqq "eq?"
-:name_equal "equal?"
-:name_plus "+"
-:name_minus "-"
-:name_mult "*"
-:name_eq "="
-:name_lt "<"
-:name_gt ">"
-:name_quotient "quotient"
-:name_remainder "remainder"
+:name_procedureq "procedure?" 00 00 00 00 00
+:name_zeroq "zero?" 00 00
+:name_not "not" 00 00 00 00
+:name_eqq "eq?" 00 00 00 00
+:name_equal "equal?" 00
+:name_plus "+" 00 00 00 00 00 00
+:name_minus "-" 00 00 00 00 00 00
+:name_mult "*" 00 00 00 00 00 00
+:name_eq "=" 00 00 00 00 00 00
+:name_lt "<" 00 00 00 00 00 00
+:name_gt ">" 00 00 00 00 00 00
+:name_quotient "quotient" 00 00 00 00 00 00 00
+:name_remainder "remainder" 00 00 00 00 00 00
:name_bit_and "bit-and"
-:name_bit_or "bit-or"
+:name_bit_or "bit-or" 00
:name_bit_xor "bit-xor"
:name_bit_not "bit-not"
-:name_arith_shift "arithmetic-shift"
-:name_apply "apply"
+:name_arith_shift "arithmetic-shift" 00 00 00 00 00 00 00
+:name_apply "apply" 00 00
:name_make_bv "make-bytevector"
-:name_bv_length "bytevector-length"
-;; "string-length" + NUL = 14 bytes; pad with 2 '00' to 16 (multiple of 8)
-;; so the sum of all name strings stays 8-aligned for the prim_table $()
-;; rows that follow.
-:name_string_length "string-length" '00' '00'
-:name_bv_u8_ref "bytevector-u8-ref"
-:name_bv_u8_set "bytevector-u8-set!"
+:name_bv_length "bytevector-length" 00 00 00 00 00 00
+:name_string_length "string-length" 00 00
+:name_bv_u8_ref "bytevector-u8-ref" 00 00 00 00 00 00
+:name_bv_u8_set "bytevector-u8-set!" 00 00 00 00 00
:name_bv_copy "bytevector-copy"
-:name_bv_copy_b "bytevector-copy!"
-:name_bv_eq "bytevector=?"
-
-:name_sys_read "sys-read"
-:name_sys_write "sys-write"
-:name_sys_close "sys-close"
-:name_sys_openat "sys-openat"
-:name_sys_clone "sys-clone"
-:name_sys_execve "sys-execve"
-:name_sys_waitid "sys-waitid"
-:name_sys_argv "sys-argv"
-:name_eof_object "eof-object"
-:name_eof_objectq "eof-object?"
+:name_bv_copy_b "bytevector-copy!" 00 00 00 00 00 00 00
+:name_bv_eq "bytevector=?" 00 00 00
+
+:name_sys_read "sys-read" 00 00 00 00 00 00 00
+:name_sys_write "sys-write" 00 00 00 00 00 00
+:name_sys_close "sys-close" 00 00 00 00 00 00
+:name_sys_openat "sys-openat" 00 00 00 00 00
+:name_sys_clone "sys-clone" 00 00 00 00 00 00
+:name_sys_execve "sys-execve" 00 00 00 00 00
+:name_sys_waitid "sys-waitid" 00 00 00 00 00
+:name_sys_argv "sys-argv" 00 00 00 00 00 00 00
+:name_eof_object "eof-object" 00 00 00 00 00
+:name_eof_objectq "eof-object?" 00 00 00 00
:name_display "display"
-:name_write "write"
-:name_error "error"
-:name_format "format"
+:name_write "write" 00 00
+:name_error "error" 00 00
+:name_format "format" 00
;; The last three names are padded individually to 16 bytes (multiple
;; of 8) so subsequent 8-aligned data slots (prim_table $() rows, the
;; bss pointer slots) stay aligned. M0 appends a NUL to every "..."
;; string, so the listed length below counts the trailing NUL plus the
-;; explicit '00' bytes.
-;; "heap-mark" + NUL = 10 bytes; pad with 6 '00' to reach 16.
-;; "heap-rewind!"+ NUL = 13 bytes; pad with 3 '00' to reach 16.
-;; "heap-usage" + NUL = 11 bytes; pad with 5 '00' to reach 16.
-:name_heap_mark "heap-mark" '00' '00' '00' '00' '00' '00'
-:name_heap_rewind_bang "heap-rewind!" '00' '00' '00'
-:name_heap_usage "heap-usage" '00' '00' '00' '00' '00'
+;; explicit 00 bytes.
+;; "heap-mark" + NUL = 10 bytes; pad with 6 00 to reach 16.
+;; "heap-rewind!"+ NUL = 13 bytes; pad with 3 00 to reach 16.
+;; "heap-usage" + NUL = 11 bytes; pad with 5 00 to reach 16.
+:name_heap_mark "heap-mark" 00 00 00 00 00 00
+:name_heap_rewind_bang "heap-rewind!" 00 00 00
+:name_heap_usage "heap-usage" 00 00 00 00 00
# Writer string constants. Lengths are hard-coded at the str_putn call
# sites (write_to_bv branches). No NUL needed in the source bytes --
# str_putn takes (ptr, n).
-:str_false "#f"
-:str_true "#t"
-:str_nil "()"
-:str_unspec "#!unspec"
-:str_unbound "#!unbound"
-:str_eof "#!eof"
-:str_closure "#<closure>"
-:str_prim "#<prim>"
-:str_td "#<rec-type>"
-:str_rec "#<record>"
-:str_unknown "#<unknown>"
+:str_false "#f" 00 00 00 00 00 00
+:str_true "#t" 00 00 00 00 00 00
+:str_nil "()" 00 00 00 00 00 00
+:str_unspec "#!unspec" 00 00 00 00 00 00 00 00
+:str_unbound "#!unbound" 00 00 00 00 00 00 00
+:str_eof "#!eof" 00 00 00
+:str_closure "#<closure>" 00 00 00 00 00 00
+:str_prim "#<prim>" 00
+:str_td "#<rec-type>" 00 00 00 00 00
+:str_rec "#<record>" 00 00 00 00 00 00 00
+:str_unknown "#<unknown>" 00 00 00 00 00 00
:str_error_prefix "scheme1: error: "
# Primitive registration table. Each entry: 8-byte name_ptr (4-byte label
@@ -5150,26 +5287,26 @@
&name_heap_rewind_bang %(0) $(12) &prim_heap_rewind_bang_entry %(0)
:prim_table_end
-:msg_usage "scheme1: usage: scheme1 SOURCE.scm" '0a' '00'
-:msg_load_fail "scheme1: failed to read source" '0a' '00'
-:msg_symtab_full "scheme1: symbol table full" '0a' '00'
-:msg_unexp_rparen "scheme1: unexpected ')'" '0a' '00'
-:msg_bad_hash "scheme1: bad #-syntax" '0a' '00'
-:msg_unexp_eof "scheme1: unexpected EOF in form" '0a' '00'
-:msg_unterm_list "scheme1: unterminated list" '0a' '00'
-:msg_unbound "scheme1: unbound variable" '0a' '00'
-:msg_not_proc "scheme1: not a procedure" '0a' '00'
-:msg_heap_full "scheme1: heap exhausted" '0a' '00'
-:msg_readbuf_full "scheme1: source buffer overflow" '0a' '00'
-:msg_bv_oob "scheme1: bytevector index out of range" '0a' '00'
-:msg_unterm_string "scheme1: unterminated string literal" '0a' '00'
-:msg_bad_escape "scheme1: bad string escape" '0a' '00'
-:msg_bad_char "scheme1: bad #\\ character literal" '0a' '00'
-:msg_bad_number "scheme1: bad number literal" '0a' '00'
-:msg_bad_ident "scheme1: bad identifier" '0a' '00'
-:msg_internal_define "scheme1: internal define is not supported (use letrec)" '0a' '00'
-:msg_pmatch_no_match "scheme1: pmatch: no clause matched" '0a' '00'
-:msg_bad_unquote_pattern "scheme1: pmatch: malformed ,-pattern" '0a' '00'
+:msg_usage "scheme1: usage: scheme1 SOURCE.scm" '0a' 00
+:msg_load_fail "scheme1: failed to read source" '0a' 00
+:msg_symtab_full "scheme1: symbol table full" '0a' 00
+:msg_unexp_rparen "scheme1: unexpected ')'" '0a' 00
+:msg_bad_hash "scheme1: bad #-syntax" '0a' 00
+:msg_unexp_eof "scheme1: unexpected EOF in form" '0a' 00
+:msg_unterm_list "scheme1: unterminated list" '0a' 00
+:msg_unbound "scheme1: unbound variable" '0a' 00
+:msg_not_proc "scheme1: not a procedure" '0a' 00
+:msg_heap_full "scheme1: heap exhausted" '0a' 00
+:msg_readbuf_full "scheme1: source buffer overflow" '0a' 00
+:msg_bv_oob "scheme1: bytevector index out of range" '0a' 00
+:msg_unterm_string "scheme1: unterminated string literal" '0a' 00
+:msg_bad_escape "scheme1: bad string escape" '0a' 00
+:msg_bad_char "scheme1: bad #\\ character literal" '0a' 00
+:msg_bad_number "scheme1: bad number literal" '0a' 00
+:msg_bad_ident "scheme1: bad identifier" '0a' 00
+:msg_internal_define "scheme1: internal define is not supported (use letrec)" '0a' 00
+:msg_pmatch_no_match "scheme1: pmatch: no clause matched" '0a' 00
+:msg_bad_unquote_pattern "scheme1: pmatch: malformed ,-pattern" '0a' 00
:name_ch_tab "tab"
:name_ch_null "null"
@@ -5245,6 +5382,9 @@
:sym_letrec $(0)
:sym_and $(0)
:sym_or $(0)
+:sym_when $(0)
+:sym_unless $(0)
+:sym_case $(0)
:sym_setbang $(0)
:sym_define_record_type $(0)
:sym_pmatch $(0)
diff --git a/tests/scheme1/94-when.expected-exit b/tests/scheme1/94-when.expected-exit
@@ -0,0 +1 @@
+42
diff --git a/tests/scheme1/94-when.scm b/tests/scheme1/94-when.scm
@@ -0,0 +1,24 @@
+; (when test body...) -- if test is non-#f, eval body and return last;
+; otherwise return UNSPEC. The body forms execute left-to-right.
+
+;; --- Truthy test: body runs, last form is the value ------------------
+(if (= 5 (when #t 1 2 3 4 5)) 0 (sys-exit 1))
+
+;; --- Falsy test: body skipped; result is UNSPEC (eq? to other UNSPECs)
+(if (eq? (when #f (sys-exit 99)) (when #f 42)) 0 (sys-exit 2))
+(if (not (eq? (when #f 1) #t)) 0 (sys-exit 3))
+(if (not (eq? (when #f 1) #f)) 0 (sys-exit 4))
+(if (not (eq? (when #f 1) '())) 0 (sys-exit 5))
+
+;; --- Body side-effects fire only when test is truthy -----------------
+(define counter 0)
+(when #f (set! counter 100))
+(if (= counter 0) 0 (sys-exit 6))
+(when #t (set! counter (+ counter 1)) (set! counter (+ counter 2)))
+(if (= counter 3) 0 (sys-exit 7))
+
+;; --- Truthy non-#t value (any non-#f counts as true) -----------------
+(if (= 7 (when 0 7)) 0 (sys-exit 8))
+(if (= 7 (when '() 7)) 0 (sys-exit 9))
+
+(sys-exit 42)
diff --git a/tests/scheme1/95-unless.expected-exit b/tests/scheme1/95-unless.expected-exit
@@ -0,0 +1 @@
+17
diff --git a/tests/scheme1/95-unless.scm b/tests/scheme1/95-unless.scm
@@ -0,0 +1,24 @@
+; (unless test body...) -- mirror of `when`. Body runs (and last value
+; is returned) when test is #f; otherwise UNSPEC.
+
+;; --- Falsy test: body runs, last form is the value -------------------
+(if (= 5 (unless #f 1 2 3 4 5)) 0 (sys-exit 1))
+
+;; --- Truthy test: body skipped; result is UNSPEC ---------------------
+(if (eq? (unless #t (sys-exit 99)) (unless 0 42)) 0 (sys-exit 2))
+(if (not (eq? (unless #t 1) #t)) 0 (sys-exit 3))
+(if (not (eq? (unless #t 1) #f)) 0 (sys-exit 4))
+(if (not (eq? (unless #t 1) '())) 0 (sys-exit 5))
+
+;; --- Body side-effects fire only when test is falsy ------------------
+(define counter 0)
+(unless #t (set! counter 100))
+(if (= counter 0) 0 (sys-exit 6))
+(unless #f (set! counter (+ counter 1)) (set! counter (+ counter 2)))
+(if (= counter 3) 0 (sys-exit 7))
+
+;; --- Any non-#f counts as true (so body is skipped) ------------------
+(if (eq? (unless 0 1) (unless #t 1)) 0 (sys-exit 8))
+(if (eq? (unless '() 1) (unless #t 1)) 0 (sys-exit 9))
+
+(sys-exit 17)
diff --git a/tests/scheme1/96-case.expected-exit b/tests/scheme1/96-case.expected-exit
@@ -0,0 +1 @@
+23
diff --git a/tests/scheme1/96-case.scm b/tests/scheme1/96-case.scm
@@ -0,0 +1,48 @@
+; (case key clause...) -- evaluates key once, then walks clauses.
+; Each clause is ((datum...) body...) or (else body...). Datums are
+; literal (not evaluated) and matched eq?-style; body of the matched
+; clause is tail-evaluated. No-match (no else) returns UNSPEC.
+
+;; --- Basic match against a single datum ------------------------------
+(if (= 11 (case 1 ((1) 11) ((2) 22) (else 99))) 0 (sys-exit 1))
+(if (= 22 (case 2 ((1) 11) ((2) 22) (else 99))) 0 (sys-exit 2))
+
+;; --- Multiple datums per clause --------------------------------------
+(if (= 7 (case 3 ((1 2 3) 7) ((4 5) 8) (else 9))) 0 (sys-exit 3))
+(if (= 8 (case 5 ((1 2 3) 7) ((4 5) 8) (else 9))) 0 (sys-exit 4))
+
+;; --- else fires when no clause matches -------------------------------
+(if (= 99 (case 42 ((1) 1) ((2 3) 2) (else 99))) 0 (sys-exit 5))
+
+;; --- No match, no else: UNSPEC (eq? to other UNSPECs) ----------------
+(if (eq? (case 7 ((1) 11)) (case 9 ((2) 22))) 0 (sys-exit 6))
+(if (not (eq? (case 7 ((1) 11)) #f)) 0 (sys-exit 7))
+
+;; --- Symbols match by eq? --------------------------------------------
+(if (eq? 'red (case 'apple
+ ((banana) 'yellow)
+ ((apple cherry) 'red)
+ (else 'gray)))
+ 0 (sys-exit 8))
+
+;; --- Booleans match by eq? -------------------------------------------
+(if (= 1 (case #t ((#t) 1) ((#f) 2) (else 3))) 0 (sys-exit 9))
+(if (= 2 (case #f ((#t) 1) ((#f) 2) (else 3))) 0 (sys-exit 10))
+
+;; --- Body has multi-form sequencing; last form is the value ---------
+(define counter 0)
+(if (= 9 (case 1
+ ((1) (set! counter (+ counter 5))
+ (set! counter (+ counter 3))
+ (+ counter 1))
+ (else 0)))
+ 0 (sys-exit 11))
+(if (= counter 8) 0 (sys-exit 12))
+
+;; --- Key expression is evaluated only once ---------------------------
+(define seen 0)
+(define (bump) (set! seen (+ seen 1)) 2)
+(if (= 22 (case (bump) ((1) 11) ((2) 22) (else 99))) 0 (sys-exit 13))
+(if (= seen 1) 0 (sys-exit 14))
+
+(sys-exit 23)
