diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index f702126..cb130d0 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -6031,7 +6031,7 @@ begin { Set arithmetic: union (+), difference (-), intersection (*), equality. } if (BE.Left.ResolvedType <> nil) and (BE.Left.ResolvedType.Kind = tySet) and - (BE.Op in [boAdd, boSub, boMul, boEQ, boNE]) then + (BE.Op in [boAdd, boSub, boMul, boEQ, boNE, boLE, boGE]) then begin if IsJumboSet(BE.Left.ResolvedType) then begin @@ -6050,6 +6050,28 @@ begin Self.Emit(#9'xorl $1, %eax'); Exit; end; + { Subset (<=) / superset (>=): _SetSubset(A, B) tests A subset of B. + For >= the operands are swapped (B subset of A). } + if BE.Op in [boLE, boGE] then + begin + Self.EmitExprToEax(BE.Left); + Self.Emit(#9'pushq %rax'); + Self.EmitExprToEax(BE.Right); + if BE.Op = boLE then + begin + Self.Emit(#9'movq %rax, %rsi'); { B } + Self.Emit(#9'popq %rdi'); { A } + end + else + begin + Self.Emit(#9'movq %rax, %rdi'); { B -> A-arg } + Self.Emit(#9'popq %rsi'); { A -> B-arg } + end; + Self.Emit(Format(#9'movl $%d, %%edx', + [JumboSetNBytes(BE.Left.ResolvedType)])); + Self.Emit(#9'callq _SetSubset'); + Exit; + end; { Union/intersection/difference: write the result into a frame scratch slot and return its address. The _Set helper takes rdi=dest, rsi=A, rdx=B, ecx=nbytes. %r12/%r13 are callee-saved across the two @@ -6096,6 +6118,25 @@ begin Self.Emit(#9'setne %al'); Self.Emit(#9'movzbl %al, %eax'); end; + boLE, boGE: + begin + { subset s<=t: (s and not t)=0 ; superset s>=t: (t and not s)=0. + %rax=s (left), %rcx=t (right). For <= mask = s and not t; for >= + mask = t and not s. Then test the mask is zero. } + if BE.Op = boLE then + begin + Self.Emit(#9'notq %rcx'); { ~t } + Self.Emit(#9'andq %rcx, %rax'); { s and ~t } + end + else + begin + Self.Emit(#9'notq %rax'); { ~s } + Self.Emit(#9'andq %rcx, %rax'); { t and ~s } + end; + Self.Emit(#9'testq %rax, %rax'); + Self.Emit(#9'sete %al'); + Self.Emit(#9'movzbl %al, %eax'); + end; end; Exit; end; diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index ee57363..91b5f84 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -9019,6 +9019,9 @@ var DataTemp: string; SQT: string; PMark: Integer; + CmpTemp: string; + SetTmpA: string; + SetTmpB: string; SetNB: Integer; { jumbo set bitmap byte count } SetRS: Integer; { jumbo set slot size (RawSize, 8-rounded) } begin @@ -11991,6 +11994,12 @@ begin [ArgTemp, L, R, SetNB])); EmitLine(Format(' %s =w ceqw %s, 0', [T, ArgTemp])); end; + boLE: { subset: A subset of B } + EmitLine(Format(' %s =w call $_SetSubset(l %s, l %s, w %d)', + [T, L, R, SetNB])); + boGE: { superset: B subset of A } + EmitLine(Format(' %s =w call $_SetSubset(l %s, l %s, w %d)', + [T, R, L, SetNB])); else raise ECodeGenError.Create(Format( 'Operator not supported for set types at line %d', [BinExpr.Line])); @@ -12019,6 +12028,24 @@ begin EmitLine(Format(' %s =w cnel %s, %s', [T, L, R])) else EmitLine(Format(' %s =w cnew %s, %s', [T, L, R])); + boLE, { subset: s <= t iff (s and not t) = 0 } + boGE: { superset: s >= t iff (t and not s) = 0 } + begin + { Pick which operand must be fully contained in the other. } + if BinExpr.Op = boLE then + begin ArgTemp := L; CmpTemp := R; end + else + begin ArgTemp := R; CmpTemp := L; end; + { notOther := ~CmpTemp ; rem := ArgTemp and notOther ; result := rem = 0 } + SetTmpA := AllocTemp(); + EmitLine(Format(' %s =%s xor %s, -1', [SetTmpA, SQT, CmpTemp])); + SetTmpB := AllocTemp(); + EmitLine(Format(' %s =%s and %s, %s', [SetTmpB, SQT, ArgTemp, SetTmpA])); + if SQT = 'l' then + EmitLine(Format(' %s =w ceql %s, 0', [T, SetTmpB])) + else + EmitLine(Format(' %s =w ceqw %s, 0', [T, SetTmpB])); + end; else raise ECodeGenError.Create(Format( 'Operator not supported for set types at line %d', [BinExpr.Line])); diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 84a6962..c1945f3 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -5526,6 +5526,7 @@ var Typ: TTypeDesc; VarName: string; Sym: TSymbol; + EnumShadowSym: TSymbol; begin for I := 0 to ABlock.Decls.Count - 1 do begin @@ -5587,6 +5588,19 @@ begin Format('Duplicate identifier ''%s'' — a type with this name is ' + 'already visible', [VarName]), Decl.Line, Decl.Col); + { A variable may not share a name with a visible ENUM MEMBER (case- + insensitive). Shadowing it silently retargets the member in a set + literal `[A, c, D]` to the variable — which is not a constant, so QBE + errors cryptically and native miscompiles the bitmask. Reject it, in + the same spirit as the type-name rule above. } + EnumShadowSym := FTable.Lookup(VarName); + if (EnumShadowSym <> nil) and (EnumShadowSym.Kind = skConstant) and + (EnumShadowSym.TypeDesc <> nil) and + (EnumShadowSym.TypeDesc.Kind = tyEnum) then + SemanticError( + Format('Duplicate identifier ''%s'' — an enum member with this name ' + + 'is already visible', [VarName]), + Decl.Line, Decl.Col); if Decl.IsThreadVar and not Decl.IsGlobal then SemanticError('threadvar is only allowed at unit or program scope', Decl.Line, Decl.Col); @@ -9986,7 +10000,8 @@ begin Format('Incompatible set types in ''%s'': ''%s'' vs ''%s''', [BinaryOpName(ABin.Op), LType.Name, RType.Name]), ABin.Line, ABin.Col); - if ABin.Op in [boEQ, boNE] then + if ABin.Op in [boEQ, boNE, boLE, boGE] then + { = <> equality; <= subset; >= superset — all yield Boolean. } Result := FTable.TypeBoolean else if ABin.Op in [boAdd, boSub, boMul] then Result := LType diff --git a/compiler/src/test/pascal/cp.test.e2e.sets.pas b/compiler/src/test/pascal/cp.test.e2e.sets.pas index 49e1bcd..90859ea 100644 --- a/compiler/src/test/pascal/cp.test.e2e.sets.pas +++ b/compiler/src/test/pascal/cp.test.e2e.sets.pas @@ -40,6 +40,7 @@ type procedure TestRun_Set_EqualityWithLiteral; procedure TestRun_Set_ForIn_PrintsMembers; procedure TestRun_Set_RangeLiteral_Membership; + procedure TestRun_Set_SubsetSuperset; { 33..64-member sets (the QBE 'l' / 64-bit register boundary) } procedure TestRun_Set64_InOperator_HighBit; @@ -169,6 +170,21 @@ const end. '''; + { Subset (<=) and superset (>=) operators. } + SrcSetSubset = ''' + program Prg; + type TC = (Aa, Bb, Cc, Dd); + var s, t: set of TC; + begin + s := [Aa, Bb]; t := [Aa, Bb, Cc]; + WriteLn(s <= t); + WriteLn(t <= s); + WriteLn(s >= t); + WriteLn(t >= s); + WriteLn(s <= s) + end. + '''; + { Set range literal (issue #105): [m1..m3] and a mixed [m0, m2..m4, m7]. } SrcSetRange = ''' program Prg; @@ -324,6 +340,14 @@ begin 'n' + LE + 'y' + LE + 'y' + LE, 0); end; +procedure TE2ESetOpsTests.TestRun_Set_SubsetSuperset; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { s<=t, t<=s, s>=t, t>=s, s<=s } + AssertRunsOnAll(SrcSetSubset, + 'True' + LE + 'False' + LE + 'False' + LE + 'True' + LE + 'True' + LE, 0); +end; + procedure TE2ESetOpsTests.TestRun_Set64_InOperator_HighBit; begin if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; diff --git a/compiler/src/test/pascal/cp.test.semantic.pas b/compiler/src/test/pascal/cp.test.semantic.pas index bf64c49..a6e4504 100644 --- a/compiler/src/test/pascal/cp.test.semantic.pas +++ b/compiler/src/test/pascal/cp.test.semantic.pas @@ -36,6 +36,7 @@ type procedure TestVarDecl_DuplicatesInterfaceType_RaisesError; procedure TestVarDecl_ShadowsBuiltinType_RaisesError; procedure TestVarDecl_ShadowsOuterScopeType_RaisesError; + procedure TestVarDecl_ShadowsEnumMember_RaisesError; { Const then var with same name in same block is a duplicate } procedure TestVarDecl_DuplicatesConst_RaisesError; { Const redeclared with same name in same block is a duplicate } @@ -234,6 +235,15 @@ begin 'begin Q(); end.'); end; +procedure TSemanticTests.TestVarDecl_ShadowsEnumMember_RaisesError; +begin + { A var may not shadow a visible enum member — shadowing silently retargets + the member in a set literal to the variable, miscompiling the bitmask. + Blaise rejects it, in the same spirit as the type-name-shadow rule. } + AnalyseExpectError( + 'program P; type TC = (A, B, C); var c: TC; begin end.'); +end; + procedure TSemanticTests.TestVarDecl_DuplicatesConst_RaisesError; begin AnalyseExpectError( diff --git a/docs/language-rationale.adoc b/docs/language-rationale.adoc index 2f9a873..f48eee1 100644 --- a/docs/language-rationale.adoc +++ b/docs/language-rationale.adoc @@ -4412,6 +4412,24 @@ when the variable clashes with a type declared in the *same* scope, and silently permits a variable to shadow a built-in or outer-scope type (`var Integer: Int64` compiles in FPC). +The same rule applies to *enum members*: a variable may not share its name with +a visible enum constant. + +[source,pascal] +---- +type TC = (A, B, C, D); +var c: TC; // ERROR: 'c' and the enum member 'C' are the same identifier +---- + +Without this rule the variable shadows the member, so a set literal that names +the member — `s := [A, C, D]` — silently resolves `C` to the variable (not the +constant). That is not a compile-time constant, so the QBE backend rejects it +with a cryptic message while the native backend produced a *wrong bitmap with +no error at all* (the member's bit was simply dropped). Rejecting the shadow +at the declaration, with `Duplicate identifier 'X' — an enum member with this +name is already visible`, removes both failure modes (FPC/Delphi allow the +shadow; Blaise does not, consistent with the type-name rule above). + === Rationale A variable that bears the same name as a type is almost always a mistake, and diff --git a/runtime/src/main/pascal/blaise_set.pas b/runtime/src/main/pascal/blaise_set.pas index ba9eecb..91140db 100644 --- a/runtime/src/main/pascal/blaise_set.pas +++ b/runtime/src/main/pascal/blaise_set.pas @@ -42,6 +42,7 @@ procedure _SetUnion(Dest, A, B: Pointer; NBytes: Integer); { Dest := A or B } procedure _SetInter(Dest, A, B: Pointer; NBytes: Integer); { Dest := A and B } procedure _SetDiff(Dest, A, B: Pointer; NBytes: Integer); { Dest := A and not B } function _SetEqual(A, B: Pointer; NBytes: Integer): Integer; { 1 if equal } +function _SetSubset(A, B: Pointer; NBytes: Integer): Integer; { 1 if A subset of B } procedure _SetCopy(Dest, Src: Pointer; NBytes: Integer); { byte copy } implementation @@ -149,6 +150,22 @@ begin Result := 1; end; +{ 1 if A is a subset of B (every bit set in A is also set in B), else 0. } +function _SetSubset(A, B: Pointer; NBytes: Integer): Integer; +var + I: Integer; +begin + I := 0; + while I < NBytes do + begin + { A byte of A has a bit absent from B iff (A[i] and not B[i]) <> 0. } + if (GetByte(A, I) and not GetByte(B, I)) <> 0 then + Exit(0); + Inc(I); + end; + Result := 1; +end; + procedure _SetCopy(Dest, Src: Pointer; NBytes: Integer); var I: Integer;