Kaynağa Gözat

compiler: comma-separated CASE labels, and ranges that work

CALC.INC's IBMCh has

    'G', 'I', 'O', 'Q': Ch := #00;

and the parser read ONE label, then demanded ':', so the list was
ENoSemi.  The labels are now read into a small array first; one label
keeps the original bytes, while a list emits one test per label.

Behind it was a worse bug: a CASE RANGE never matched.  The emitter
compared the selector with lo and then with hi, BOTH requiring equality,
so `1..5' matched nothing unless lo = hi.  A minimal probe

    i := 3; case i of 1..5: writeln('in') else writeln('out') end

printed `out' - no error, a wrong answer.  The single-label range now
tests AX < lo and AX > hi (JL/JG), and a range inside a list does the
same with an unconditional jump into the body.  JLE would be shorter,
but check_8086's declared branch conditions are exactly Z/NZ/L/G - the
four the parser's comparisons use - and emitting a fifth would (rightly)
be reported there.

t74_caselist pins a char list hit and miss, a range's low edge and high
edge, a list mixing values and ranges (hit, miss, high edge).  It is red
before at compile time (the list) and the old range behaviour is red at
execution (the probe above); non-vacuity now inverts the high test and
demands t74 go red at execution, not at compile.

The ladder jumps 13052 -> 14195, now `XPos[Count]' - a variable ARRAY
subscript (string subscripts have been run-time since v-TP3-STRIDX-VAR;
arrays still fold a constant index only).
Eric Streit 2 gün önce
ebeveyn
işleme
24b479d7c0

+ 107 - 30
shell/Compiler.mod

@@ -311,6 +311,8 @@ VAR
 
    caseJmp : ARRAY [0..63] OF CARDINAL ;
    caseN   : CARDINAL ;
+   lblLo, lblHi : ARRAY [0..31] OF LONGINT ;  (* one arm's label list *)
+   lblJmp : ARRAY [0..63] OF CARDINAL ;       (* its body jumps: 1 or 2 per label *)
 
    pc, dc  : CARDINAL ;
    varspc  : CARDINAL ;
@@ -4139,6 +4141,7 @@ VAR tok : CARDINAL ;
     lo, hi, v : LONGINT ;
     clso : CARDINAL ;
     i : CARDINAL ;
+    k, nlbl, nlblJmp, bodyPc, skipJmp : CARDINAL ;
     nm : ARRAY [0..MaxName] OF CHAR ;
     strf : BOOLEAN ;
     dow : BOOLEAN ;
@@ -4380,43 +4383,117 @@ BEGIN
          IF (tok = TkEnd) OR (tok = TkElse) THEN
             EXIT
          END ;
-         (* case label : constant identifier or literal *)
-         IF Alpha (CurCh ()) THEN
-            GetWord () ;
-            IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN
-               lo := symtab [i2].lval
+         (* Case labels: `v' | `lo..hi', comma-separated, all selecting the
+            same statement (CALC's `'G', 'I', 'O', 'Q':').  Read the whole list
+            first; the emission then knows whether this is the one-label path
+            or a list. *)
+         nlbl := 0 ;
+         LOOP
+            IF Alpha (CurCh ()) THEN
+               GetWord () ;
+               IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN
+                  lo := symtab [i2].lval
+               ELSE
+                  Err (EUnknown) ;
+                  RETURN
+               END
+            ELSE
+               RdConst (lo, clso, strf)
+            END ;
+            IF MatchRange () THEN
+               RdConst (hi, clso, strf)
+            ELSE
+               hi := lo
+            END ;
+            IF nlbl >= 32 THEN
+               Err (ECompOvf) ;
+               RETURN
+            END ;
+            lblLo [nlbl] := lo ;
+            lblHi [nlbl] := hi ;
+            INC (nlbl) ;
+            IF MatchDelim (',') THEN
+               Skip ()
             ELSE
-               Err (EUnknown) ;
                EXIT
             END
-         ELSE
-            RdConst (lo, clso, strf)
-         END ;
-         IF MatchRange () THEN
-            RdConst (hi, clso, strf)
-         ELSE
-            hi := lo
          END ;
+         Skip () ;
          ExpectDelim (':', ENoSemi) ;
+         IF NOT OK () THEN
+            RETURN
+         END ;
          EmMovAxSp () ;
-         EmCmpAxi (W16 (lo)) ;
-         zj := EmJcc (85H, 0) ;        (* JNZ -> next *)
-         IF hi # lo THEN
-            EmCmpAxi (W16 (hi)) ;
-            zj2 := EmJcc (85H, 0)
+         IF nlbl = 1 THEN
+            (* One label: the original bytes, except that a RANGE is now a
+               real range.  It used to compare AX with lo and then with hi,
+               both demanding equality, so `1..5' matched NOTHING unless
+               lo = hi - a silently wrong answer, not an error. *)
+            lo := lblLo [0] ;
+            hi := lblHi [0] ;
+            IF hi = lo THEN
+               EmCmpAxi (W16 (lo)) ;
+               zj := EmJcc (85H, 0) ;        (* JNZ -> next arm *)
+               zj2 := 0
+            ELSE
+               EmCmpAxi (W16 (lo)) ;
+               zj := EmJcc (8CH, 0) ;        (* JL -> next arm *)
+               EmCmpAxi (W16 (hi)) ;
+               zj2 := EmJcc (8FH, 0)         (* JG -> next arm *)
+            END ;
+            Statmnt () ;
+            IF caseN >= 64 THEN
+               Err (ECompOvf) ;
+               RETURN
+            END ;
+            caseJmp [caseN] := EmJmpNear (0) ;
+            INC (caseN) ;
+            SetPatTgt (zj, pc) ;
+            IF zj2 # 0 THEN
+               SetPatTgt (zj2, pc)
+            END
          ELSE
-            zj2 := 0
-         END ;
-         Statmnt () ;
-         IF caseN >= 64 THEN
-            Err (ECompOvf) ;
-            EXIT
-         END ;
-         caseJmp [caseN] := EmJmpNear (0) ;
-         INC (caseN) ;
-         SetPatTgt (zj, pc) ;
-         IF zj2 # 0 THEN
-            SetPatTgt (zj2, pc)
+            (* A list.  A single label branches INTO the statement; a range
+               first sends AX below lo to the next label, then `<= hi' to the
+               body.  The body jumps are patched once the body's address is
+               known, and the no-match EJMP skips the body to the next arm. *)
+            nlblJmp := 0 ;
+            FOR k := 0 TO nlbl - 1 DO
+               IF lblHi [k] = lblLo [k] THEN
+                  EmCmpAxi (W16 (lblLo [k])) ;
+                  lblJmp [nlblJmp] := EmJcc (84H, 0) ;  (* JZ -> body *)
+                  INC (nlblJmp)
+               ELSE
+                  (* `lo <= AX <= hi', built from the two conditions this
+                     compiler declares for a branch (L and G): below lo skips
+                     the label, above hi skips it, otherwise an unconditional
+                     jump enters the body.  JLE would be shorter and is legal
+                     8086, but check_8086's declared condition set is exactly
+                     Z/NZ/L/G (the four the parser's comparisons use), and a
+                     new condition in CASE would rightly be reported there. *)
+                  EmCmpAxi (W16 (lblLo [k])) ;
+                  zj := EmJcc (8CH, 0) ;               (* JL -> next label *)
+                  EmCmpAxi (W16 (lblHi [k])) ;
+                  zj2 := EmJcc (8FH, 0) ;              (* JG -> next label *)
+                  lblJmp [nlblJmp] := EmJmpNear (0) ;  (* in range -> body *)
+                  INC (nlblJmp) ;
+                  SetPatTgt (zj, pc) ;
+                  SetPatTgt (zj2, pc)
+               END
+            END ;
+            skipJmp := EmJmpNear (0) ;
+            bodyPc := pc ;
+            FOR k := 0 TO nlblJmp - 1 DO
+               SetPatTgt (lblJmp [k], bodyPc)
+            END ;
+            Statmnt () ;
+            IF caseN >= 64 THEN
+               Err (ECompOvf) ;
+               RETURN
+            END ;
+            caseJmp [caseN] := EmJmpNear (0) ;
+            INC (caseN) ;
+            SetPatTgt (skipJmp, pc)
          END
       END ;
       IF tok = TkElse THEN

+ 7 - 6
shell/tests/fixtures/calc_ladder.tsv

@@ -25,9 +25,10 @@
 # positions shift — which is exactly why this must be a measured number, not a
 # remembered one.
 #
-# Current rung (2026-10-21): the CASE labels `'G', 'I', 'O', 'Q':' in
-# CALC.INC's IBMCh.  VAR parameters landed (by reference; t73_varparam) along
-# with the shadowing rule in DupTest, moving 12901 -> 13052.  The blocker is
-# now a COMMA-SEPARATED case label list: the parser reads one label and then
-# demands ':'.
-CALC.PAS	ERR	1	13052
+# Current rung (2026-10-21): `XPos[Count]' in CALC.INC's DisplayP - a VARIABLE
+# array subscript.  Comma-separated CASE labels and real case RANGES landed
+# (t74_caselist), moving 13052 -> 14195.  The subscript is refused ENoLib:
+# arrays still accept only a constant index (a variable index needs the
+# element-size scaling), while string subscripts have been run-time since
+# v-TP3-STRIDX-VAR.
+CALC.PAS	ERR	102	14195

+ 6 - 0
shell/tests/fixtures/expected.tsv

@@ -570,3 +570,9 @@ t72_keypress	OK	138	6
 #                   relayed to another, and READ into a VAR parameter.  A
 #                   value implementation prints H,H,41,a instead of h,h,42,?.
 t73_varparam	OK	334	8
+#   t74_caselist           comma-separated CASE labels (CALC's 'G','I','O','Q')
+#                   and REAL ranges.  The range emitter used to compare the
+#                   selector with lo AND hi, both demanding equality, so
+#                   `1..5' matched nothing unless lo=hi; the fixture pins the
+#                   low edge, the high edge, a mixed list, and misses.
+t74_caselist	OK	579	8

+ 7 - 0
shell/tests/fixtures/t74_caselist.out

@@ -0,0 +1,7 @@
+group
+other
+range
+range
+list
+miss
+list

+ 63 - 0
shell/tests/fixtures/t74_caselist.pas

@@ -0,0 +1,63 @@
+program t74_caselist;
+
+{ t74 -- comma-separated CASE labels, and ranges that actually work.
+
+  CALC.INC's IBMCh has
+
+      'G', 'I', 'O', 'Q': Ch := #00;
+
+  The parser read ONE label and then demanded ':', so the list was ENoSemi.
+  While fixing that, the range emitter turned out to be wrong too: it compared
+  the selector with lo and then with hi, BOTH requiring equality, so `1..5'
+  matched nothing unless lo = hi.  A minimal probe (i := 3; case i of 1..5)
+  printed the ELSE arm.  No error, just a wrong answer - which is why this
+  fixture pins the low edge, the high edge, a list mixing values and ranges,
+  and misses on both a char list and a range list. }
+
+var
+   c : char;
+   i : integer;
+begin
+   c := 'I';
+   case c of
+      'G', 'I', 'O', 'Q': writeln ('group')
+   else
+      writeln ('other')
+   end;
+   c := 'A';
+   case c of
+      'G', 'I', 'O', 'Q': writeln ('group')
+   else
+      writeln ('other')
+   end;
+   i := 3;
+   case i of
+      1..5: writeln ('range')
+   else
+      writeln ('outside')
+   end;
+   i := 5;
+   case i of
+      1..5: writeln ('range')
+   else
+      writeln ('outside')
+   end;
+   i := 7;
+   case i of
+      1..5, 7, 9..10: writeln ('list')
+   else
+      writeln ('miss')
+   end;
+   i := 8;
+   case i of
+      1..5, 7, 9..10: writeln ('list')
+   else
+      writeln ('miss')
+   end;
+   i := 10;
+   case i of
+      1..5, 7, 9..10: writeln ('list')
+   else
+      writeln ('miss')
+   end
+end.

+ 20 - 0
shell/tests/nonvacuity.sh

@@ -1830,6 +1830,26 @@ else
 fi
 cp "$SAVED_C" Compiler.mod
 
+# --- a CASE range is a range ----------------------------------------------
+# The old emitter compared the selector with lo and then with hi, both
+# demanding equality, so `1..5' matched nothing.  Invert only the high test:
+# i=5 in t74's `1..5' arm then falls through to ELSE, and the .out says
+# `range'.  This is an execution failure, not a compile failure - the range
+# compiled and ran, and answered wrongly.
+cp "$SAVED_C" Compiler.mod
+if mutate_compiler 's|EmJcc (8FH, 0)|EmJcc (84H, 0)|'; then
+    if rebuild_compiler; then
+        expect_red "t74 red when a CASE range requires equality"             "FAIL" python3 tests/run_com_exec.py t74_caselist
+    else
+        echo "  FAIL: the compiler would not rebuild with the broken range test"
+        fail=$((fail + 1))
+    fi
+else
+    echo "  BROKEN CASE: the CASE-range mutation did not apply"
+    fail=$((fail + 1))
+fi
+cp "$SAVED_C" Compiler.mod
+
 if rebuild_compiler; then
     if python3 tests/run_com_exec.py >/dev/null 2>&1; then
         echo "  ok: every executed fixture passes on the restored sources"