feat(sets): support ordinal-based set types — set of Byte / Boolean (#105)
Widen set base types from enum-only to also accept Byte (256-bit jumbo) and Boolean (2-bit small). Set literals accept integer literals and range syntax [lo..hi], expanded at compile time via EvalConstIntExpr. Include/Exclude and the in operator accept numeric arguments for ordinal base types. Both QBE and native backends handle TIntLiteral elements in set mask computation. 15 new IR unit tests and 4 new E2E tests (both backends via AssertRunsOnAll). All 3444 tests pass; FIXPOINT_OK, NATIVE_FIXPOINT_OK, NATIVE_INTERNAL_OK.
This commit is contained in:
Graeme Geldenhuys
parent
b0499aa454
commit
f6d488bca4
|
|
@ -7135,7 +7135,9 @@ begin
|
|||
for SetI := 0 to TArrayLiteralExpr(AExpr).Elements.Count - 1 do
|
||||
begin
|
||||
SetElem := TASTExpr(TArrayLiteralExpr(AExpr).Elements.Items[SetI]);
|
||||
if (SetElem is TIdentExpr) and TIdentExpr(SetElem).IsConstant then
|
||||
if SetElem is TIntLiteral then
|
||||
SetMask := SetMask or (Int64(1) shl TIntLiteral(SetElem).Value)
|
||||
else if (SetElem is TIdentExpr) and TIdentExpr(SetElem).IsConstant then
|
||||
SetMask := SetMask or (Int64(1) shl TIdentExpr(SetElem).ConstValue);
|
||||
end;
|
||||
if TSetTypeDesc(AExpr.ResolvedType).BitCount > 32 then
|
||||
|
|
|
|||
|
|
@ -14536,13 +14536,18 @@ begin
|
|||
for I := 0 to AExpr.Elements.Count - 1 do
|
||||
begin
|
||||
Elem := TASTExpr(AExpr.Elements.Items[I]);
|
||||
if not (Elem is TIdentExpr) then
|
||||
raise ECodeGenError.Create('Set literal elements must be enum constant references');
|
||||
IdExpr := TIdentExpr(Elem);
|
||||
if not IdExpr.IsConstant then
|
||||
raise ECodeGenError.Create(Format(
|
||||
'Set literal element ''%s'' is not a constant', [IdExpr.Name]));
|
||||
Mask := Mask or (Int64(1) shl IdExpr.ConstValue);
|
||||
if Elem is TIntLiteral then
|
||||
Mask := Mask or (Int64(1) shl TIntLiteral(Elem).Value)
|
||||
else if Elem is TIdentExpr then
|
||||
begin
|
||||
IdExpr := TIdentExpr(Elem);
|
||||
if not IdExpr.IsConstant then
|
||||
raise ECodeGenError.Create(Format(
|
||||
'Set literal element ''%s'' is not a constant', [IdExpr.Name]));
|
||||
Mask := Mask or (Int64(1) shl IdExpr.ConstValue);
|
||||
end
|
||||
else
|
||||
raise ECodeGenError.Create('Set literal elements must be constants');
|
||||
end;
|
||||
Tmp := AllocTemp();
|
||||
QT := QbeTypeOf(AExpr.ResolvedType);
|
||||
|
|
|
|||
|
|
@ -260,6 +260,7 @@ type
|
|||
{ Expand [lo..hi] range elements of a set literal into individual member
|
||||
idents (issue #105). Constant ascending ranges only. }
|
||||
procedure ExpandSetRanges(AExpr: TArrayLiteralExpr; ABaseEnum: TEnumTypeDesc);
|
||||
procedure ExpandOrdinalSetRanges(AExpr: TArrayLiteralExpr; ASetType: TSetTypeDesc);
|
||||
function SetRangeBoundOrdinal(ABound: TASTExpr; ABaseEnum: TEnumTypeDesc;
|
||||
const AWhich: string): Integer;
|
||||
{ Width (in bits) needed for the anonymous set type of an 'X in [a,b,c]'
|
||||
|
|
@ -2344,9 +2345,10 @@ begin
|
|||
Exit;
|
||||
end;
|
||||
{ Inline set type: 'set of TypeName' — create on demand. The element type
|
||||
must resolve to an enum. The canonical name 'set of <Enum>' matches the
|
||||
inferred-set-constant path, so identical inline and named sets share one
|
||||
descriptor (set types compare structurally regardless). }
|
||||
must be an enum (up to 256 members) or a small ordinal type (Byte,
|
||||
Boolean). The canonical name 'set of <Base>' matches the inferred-set-
|
||||
constant path, so identical inline and named sets share one descriptor
|
||||
(set types compare structurally regardless). }
|
||||
if (Length(AName) > 7) and (StrHead(AName, 7) = 'set of ') then
|
||||
begin
|
||||
BaseName := StrCopyTail(AName, 7);
|
||||
|
|
@ -2369,7 +2371,31 @@ begin
|
|||
Result := FTable.NewSetType(CanonName, TEnumTypeDesc(BaseType));
|
||||
FTable.DefineGlobal(TSymbol.Create(CanonName, skType, Result));
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else if (BaseType <> nil) and (BaseType.Kind = tyByte) then
|
||||
begin
|
||||
CanonName := 'set of ' + BaseType.Name;
|
||||
Result := FTable.FindType(CanonName);
|
||||
if Result = nil then
|
||||
begin
|
||||
Result := FTable.NewOrdinalSetType(CanonName, BaseType, 256);
|
||||
FTable.DefineGlobal(TSymbol.Create(CanonName, skType, Result));
|
||||
end;
|
||||
end
|
||||
else if (BaseType <> nil) and (BaseType.Kind = tyBoolean) then
|
||||
begin
|
||||
CanonName := 'set of ' + BaseType.Name;
|
||||
Result := FTable.FindType(CanonName);
|
||||
if Result = nil then
|
||||
begin
|
||||
Result := FTable.NewOrdinalSetType(CanonName, BaseType, 2);
|
||||
FTable.DefineGlobal(TSymbol.Create(CanonName, skType, Result));
|
||||
end;
|
||||
end
|
||||
else if BaseType <> nil then
|
||||
SemanticError(Format(
|
||||
'Set base type ''%s'' must be an enumeration, Byte, or Boolean',
|
||||
[BaseType.Name]), 0, 0);
|
||||
Exit;
|
||||
end;
|
||||
if StrPos('<', AName) >= 0 then
|
||||
|
|
@ -4148,20 +4174,33 @@ begin
|
|||
end
|
||||
else if TD.Def is TSetTypeDef then
|
||||
begin
|
||||
{ Set type: base type must be a previously-defined enum }
|
||||
SetDef := TSetTypeDef(TD.Def);
|
||||
BaseSym := FTable.Lookup(SetDef.BaseTypeName);
|
||||
if (BaseSym = nil) or (BaseSym.Kind <> skType) or
|
||||
not (BaseSym.TypeDesc is TEnumTypeDesc) then
|
||||
if (BaseSym = nil) or (BaseSym.Kind <> skType) then
|
||||
SemanticError(
|
||||
Format('Set base type ''%s'' must be an enumeration type', [SetDef.BaseTypeName]),
|
||||
Format('Set base type ''%s'' is not a known type', [SetDef.BaseTypeName]),
|
||||
TD.Line, TD.Col);
|
||||
if TEnumTypeDesc(BaseSym.TypeDesc).Members.Count > 256 then
|
||||
if BaseSym.TypeDesc is TEnumTypeDesc then
|
||||
begin
|
||||
if TEnumTypeDesc(BaseSym.TypeDesc).Members.Count > 256 then
|
||||
SemanticError(
|
||||
Format('Enumeration ''%s'' has %d members; set types support at most 256',
|
||||
[SetDef.BaseTypeName, TEnumTypeDesc(BaseSym.TypeDesc).Members.Count]),
|
||||
TD.Line, TD.Col);
|
||||
SetDesc := FTable.NewSetType(TD.Name, TEnumTypeDesc(BaseSym.TypeDesc));
|
||||
end
|
||||
else if BaseSym.TypeDesc.Kind = tyByte then
|
||||
SetDesc := FTable.NewOrdinalSetType(TD.Name, BaseSym.TypeDesc, 256)
|
||||
else if BaseSym.TypeDesc.Kind = tyBoolean then
|
||||
SetDesc := FTable.NewOrdinalSetType(TD.Name, BaseSym.TypeDesc, 2)
|
||||
else
|
||||
begin
|
||||
SemanticError(
|
||||
Format('Enumeration ''%s'' has %d members; set types support at most 256',
|
||||
[SetDef.BaseTypeName, TEnumTypeDesc(BaseSym.TypeDesc).Members.Count]),
|
||||
Format('Set base type ''%s'' must be an enumeration, Byte, or Boolean',
|
||||
[SetDef.BaseTypeName]),
|
||||
TD.Line, TD.Col);
|
||||
SetDesc := FTable.NewSetType(TD.Name, TEnumTypeDesc(BaseSym.TypeDesc));
|
||||
SetDesc := nil;
|
||||
end;
|
||||
Sym := TSymbol.Create(TD.Name, skType, SetDesc);
|
||||
if not FTable.Define(Sym) then
|
||||
begin
|
||||
|
|
@ -7626,9 +7665,12 @@ begin
|
|||
first because an empty-literal arg has no ResolvedType. }
|
||||
if (AParam.Kind = tySet) and (AArgExpr is TArrayLiteralExpr) then
|
||||
begin
|
||||
if (TArrayLiteralExpr(AArgExpr).Elements.Count = 0) or
|
||||
(TSetTypeDesc(AParam).BaseType =
|
||||
SetLiteralBaseEnum(TArrayLiteralExpr(AArgExpr))) then
|
||||
if TArrayLiteralExpr(AArgExpr).Elements.Count = 0 then
|
||||
Result := 2
|
||||
else if TSetTypeDesc(AParam).BaseType.Kind in [tyByte, tyBoolean] then
|
||||
Result := 2
|
||||
else if TSetTypeDesc(AParam).BaseType =
|
||||
SetLiteralBaseEnum(TArrayLiteralExpr(AArgExpr)) then
|
||||
Result := 2;
|
||||
Exit;
|
||||
end;
|
||||
|
|
@ -8044,19 +8086,30 @@ begin
|
|||
Format('First argument of ''%s'' must be a set variable, got ''%s''',
|
||||
[ACall.Name, ArgType.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
{ Validate the second arg is the correct enum element type }
|
||||
if ACall.Args.Count >= 2 then
|
||||
begin
|
||||
ArgType := AnalyseExpr(TASTExpr(ACall.Args.Items[1]));
|
||||
{ The set type arg was the first; recover it }
|
||||
if (TASTExpr(ACall.Args.Items[0]).ResolvedType.Kind = tySet) and
|
||||
(ArgType <> TSetTypeDesc(TASTExpr(ACall.Args.Items[0]).ResolvedType).BaseType) then
|
||||
SemanticError(
|
||||
Format('Second argument of ''%s'' must be type ''%s'', got ''%s''',
|
||||
[ACall.Name,
|
||||
TSetTypeDesc(TASTExpr(ACall.Args.Items[0]).ResolvedType).BaseType.Name,
|
||||
ArgType.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
if TASTExpr(ACall.Args.Items[0]).ResolvedType.Kind = tySet then
|
||||
begin
|
||||
if TSetTypeDesc(TASTExpr(ACall.Args.Items[0]).ResolvedType).BaseType.Kind
|
||||
in [tyByte, tyBoolean] then
|
||||
begin
|
||||
if not ArgType.IsNumeric() then
|
||||
SemanticError(
|
||||
Format('Second argument of ''%s'' must be numeric for ''set of %s'', got ''%s''',
|
||||
[ACall.Name,
|
||||
TSetTypeDesc(TASTExpr(ACall.Args.Items[0]).ResolvedType).BaseType.Name,
|
||||
ArgType.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
end
|
||||
else if ArgType <> TSetTypeDesc(TASTExpr(ACall.Args.Items[0]).ResolvedType).BaseType then
|
||||
SemanticError(
|
||||
Format('Second argument of ''%s'' must be type ''%s'', got ''%s''',
|
||||
[ACall.Name,
|
||||
TSetTypeDesc(TASTExpr(ACall.Args.Items[0]).ResolvedType).BaseType.Name,
|
||||
ArgType.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
|
|
@ -10257,7 +10310,15 @@ begin
|
|||
SemanticError(
|
||||
Format('Right operand of ''in'' must be a set type, got ''%s''', [RType.Name]),
|
||||
ABin.Line, ABin.Col);
|
||||
if LType <> TSetTypeDesc(RType).BaseType then
|
||||
if TSetTypeDesc(RType).BaseType.Kind in [tyByte, tyBoolean] then
|
||||
begin
|
||||
if not LType.IsNumeric() then
|
||||
SemanticError(
|
||||
Format('Left operand of ''in'' must be numeric for ''set of %s'', got ''%s''',
|
||||
[TSetTypeDesc(RType).BaseType.Name, LType.Name]),
|
||||
ABin.Line, ABin.Col);
|
||||
end
|
||||
else if LType <> TSetTypeDesc(RType).BaseType then
|
||||
SemanticError(
|
||||
Format('Left operand of ''in'' must be type ''%s'', got ''%s''',
|
||||
[TSetTypeDesc(RType).BaseType.Name, LType.Name]),
|
||||
|
|
@ -11259,24 +11320,96 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.ExpandOrdinalSetRanges(AExpr: TArrayLiteralExpr;
|
||||
ASetType: TSetTypeDesc);
|
||||
var
|
||||
I, J: Integer;
|
||||
Elem: TASTExpr;
|
||||
Range: TSetRangeExpr;
|
||||
LoVal: Int64;
|
||||
HiVal: Int64;
|
||||
NewList: TObjectList;
|
||||
Lit: TIntLiteral;
|
||||
HasRanges: Boolean;
|
||||
begin
|
||||
HasRanges := False;
|
||||
for I := 0 to AExpr.Elements.Count - 1 do
|
||||
if TASTExpr(AExpr.Elements.Items[I]) is TSetRangeExpr then
|
||||
begin
|
||||
HasRanges := True;
|
||||
Break;
|
||||
end;
|
||||
if not HasRanges then Exit;
|
||||
|
||||
NewList := TObjectList.Create(False);
|
||||
try
|
||||
for I := 0 to AExpr.Elements.Count - 1 do
|
||||
begin
|
||||
Elem := TASTExpr(AExpr.Elements.Items[I]);
|
||||
if not (Elem is TSetRangeExpr) then
|
||||
begin
|
||||
NewList.Add(Elem);
|
||||
Continue;
|
||||
end;
|
||||
Range := TSetRangeExpr(Elem);
|
||||
LoVal := EvalConstIntExpr(Range.LowExpr, Range.Line, Range.Col);
|
||||
HiVal := EvalConstIntExpr(Range.HighExpr, Range.Line, Range.Col);
|
||||
if HiVal < LoVal then
|
||||
SemanticError(
|
||||
Format('Set range is reversed (%d > %d)', [LoVal, HiVal]),
|
||||
Range.Line, Range.Col);
|
||||
if (LoVal < 0) or (HiVal >= ASetType.BitCount) then
|
||||
SemanticError(
|
||||
Format('Set range %d..%d out of bounds (0..%d)',
|
||||
[LoVal, HiVal, ASetType.BitCount - 1]),
|
||||
Range.Line, Range.Col);
|
||||
for J := LoVal to HiVal do
|
||||
begin
|
||||
Lit := TIntLiteral.Create();
|
||||
Lit.Line := Range.Line;
|
||||
Lit.Col := Range.Col;
|
||||
Lit.Value := J;
|
||||
Lit.ResolvedType := ASetType.BaseType;
|
||||
NewList.Add(Lit);
|
||||
end;
|
||||
end;
|
||||
for I := AExpr.Elements.Count - 1 downto 0 do
|
||||
if not (TASTExpr(AExpr.Elements.Items[I]) is TSetRangeExpr) then
|
||||
AExpr.Elements.Extract(AExpr.Elements.Items[I]);
|
||||
AExpr.Elements.Clear();
|
||||
for I := 0 to NewList.Count - 1 do
|
||||
AExpr.Elements.Add(NewList.Items[I]);
|
||||
finally
|
||||
NewList.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSemanticAnalyser.AnalyseSetLiteralExpr(AExpr: TArrayLiteralExpr;
|
||||
ASetType: TSetTypeDesc): TTypeDesc;
|
||||
{ Validates a set literal [elem, ...] against ASetType.
|
||||
Elements must be constants or variables of the set's base enum type.
|
||||
Range elements [lo..hi] are expanded to members first (issue #105).
|
||||
An empty literal [] is valid and yields the set type with bitmask 0. }
|
||||
var
|
||||
ElemType: TTypeDesc;
|
||||
I: Integer;
|
||||
IsOrdBase: Boolean;
|
||||
begin
|
||||
IsOrdBase := ASetType.BaseType.Kind in [tyByte, tyBoolean];
|
||||
if ASetType.BaseType is TEnumTypeDesc then
|
||||
ExpandSetRanges(AExpr, TEnumTypeDesc(ASetType.BaseType))
|
||||
else if IsOrdBase then
|
||||
ExpandOrdinalSetRanges(AExpr, ASetType)
|
||||
else
|
||||
ExpandSetRanges(AExpr, nil);
|
||||
for I := 0 to AExpr.Elements.Count - 1 do
|
||||
begin
|
||||
ElemType := AnalyseExpr(TASTExpr(AExpr.Elements.Items[I]));
|
||||
if ElemType <> ASetType.BaseType then
|
||||
if IsOrdBase then
|
||||
begin
|
||||
if (not ElemType.IsNumeric()) and (ElemType <> ASetType.BaseType) then
|
||||
SemanticError(
|
||||
Format('Set literal element %d has type ''%s''; expected ''%s'' or integer',
|
||||
[I + 1, ElemType.Name, ASetType.BaseType.Name]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
end
|
||||
else if ElemType <> ASetType.BaseType then
|
||||
SemanticError(
|
||||
Format('Set literal element %d has type ''%s''; expected ''%s''',
|
||||
[I + 1, ElemType.Name, ASetType.BaseType.Name]),
|
||||
|
|
|
|||
|
|
@ -123,9 +123,9 @@ type
|
|||
function OrdinalOf(const AMember: string): Integer;
|
||||
end;
|
||||
|
||||
{ Set type descriptor. BaseType is the element enum; BitCount is the number
|
||||
of bits required (= BaseType.Members.Count). Each member ordinal N maps to
|
||||
bit N of the bitmap. Representation depends on BitCount:
|
||||
{ Set type descriptor. BaseType is the element type (enum or ordinal such
|
||||
as Byte/Word). BitCount is the number of bits required. Each member
|
||||
ordinal N maps to bit N of the bitmap. Representation depends on BitCount:
|
||||
BitCount <= 32 -> QBE 'w' (32-bit register), bit (1 shl N)
|
||||
BitCount <= 64 -> QBE 'l' (64-bit register), bit (1 shl N)
|
||||
BitCount > 64 -> JUMBO: an inline byte-array bitmap of RawByteSize
|
||||
|
|
@ -135,8 +135,8 @@ type
|
|||
register. Max 256 members -> 32 bytes. }
|
||||
TSetTypeDesc = class(TTypeDesc)
|
||||
public
|
||||
[Unretained] BaseType: TEnumTypeDesc; { not owned }
|
||||
BitCount: Integer; { = BaseType.Members.Count }
|
||||
[Unretained] BaseType: TTypeDesc; { not owned — enum or ordinal type }
|
||||
BitCount: Integer;
|
||||
{ True when this set is too wide for a single 64-bit register and must use
|
||||
the inline byte-array (aggregate) representation + _Set* RTL helpers. }
|
||||
function IsJumbo: Boolean;
|
||||
|
|
@ -546,6 +546,8 @@ type
|
|||
function NewMetaClassType(const AName: string; ABase: TTypeDesc): TMetaClassTypeDesc;
|
||||
function NewEnumType(const AName: string): TEnumTypeDesc;
|
||||
function NewSetType(const AName: string; ABase: TEnumTypeDesc): TSetTypeDesc;
|
||||
function NewOrdinalSetType(const AName: string; ABase: TTypeDesc;
|
||||
ABitCount: Integer): TSetTypeDesc;
|
||||
function NewProceduralType(const AName: string): TProceduralTypeDesc;
|
||||
|
||||
{ Creates an open-array type descriptor for element type AElementType.
|
||||
|
|
@ -1431,6 +1433,17 @@ begin
|
|||
FAllTypes.Add(Result);
|
||||
end;
|
||||
|
||||
function TSymbolTable.NewOrdinalSetType(const AName: string; ABase: TTypeDesc;
|
||||
ABitCount: Integer): TSetTypeDesc;
|
||||
begin
|
||||
Result := TSetTypeDesc.Create();
|
||||
Result.Kind := tySet;
|
||||
Result.Name := AName;
|
||||
Result.BaseType := ABase;
|
||||
Result.BitCount := ABitCount;
|
||||
FAllTypes.Add(Result);
|
||||
end;
|
||||
|
||||
function TSymbolTable.NewProceduralType(const AName: string): TProceduralTypeDesc;
|
||||
begin
|
||||
Result := TProceduralTypeDesc.Create(AName);
|
||||
|
|
|
|||
|
|
@ -47,6 +47,12 @@ type
|
|||
procedure TestRun_Set64_IncludeExclude;
|
||||
procedure TestRun_Set64_Union;
|
||||
procedure TestRun_Set64_ForIn;
|
||||
|
||||
{ set of Byte — ordinal-based sets (issue #105) }
|
||||
procedure TestRun_SetOfByte_IncludeExclude;
|
||||
procedure TestRun_SetOfByte_InOperator;
|
||||
procedure TestRun_SetOfByte_RangeLiteral;
|
||||
procedure TestRun_SetOfByte_Union;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
|
@ -376,6 +382,96 @@ begin
|
|||
'2' + LE + '40' + LE + '47' + LE, 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ set of Byte — ordinal-based sets (issue #105) }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
SrcSetOfByteIncExcl = '''
|
||||
program Prg;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [];
|
||||
Include(F, 3);
|
||||
Include(F, 100);
|
||||
if 3 in F then WriteLn('3');
|
||||
if 100 in F then WriteLn('100');
|
||||
if 50 in F then WriteLn('50');
|
||||
Exclude(F, 3);
|
||||
if 3 in F then WriteLn('3again')
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteIn = '''
|
||||
program Prg;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [1, 5, 200];
|
||||
if 1 in F then WriteLn('1');
|
||||
if 2 in F then WriteLn('2');
|
||||
if 5 in F then WriteLn('5');
|
||||
if 200 in F then WriteLn('200')
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteRange = '''
|
||||
program Prg;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
I: Integer;
|
||||
begin
|
||||
F := [10..15];
|
||||
for I := 8 to 17 do
|
||||
if I in F then
|
||||
WriteLn(I)
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteUnion = '''
|
||||
program Prg;
|
||||
type TByteFlags = set of Byte;
|
||||
var A, B, C: TByteFlags;
|
||||
begin
|
||||
A := [1, 2];
|
||||
B := [2, 3];
|
||||
C := A + B;
|
||||
if 1 in C then WriteLn('1');
|
||||
if 2 in C then WriteLn('2');
|
||||
if 3 in C then WriteLn('3');
|
||||
if 4 in C then WriteLn('4')
|
||||
end.
|
||||
''';
|
||||
|
||||
procedure TE2ESetOpsTests.TestRun_SetOfByte_IncludeExclude;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertRunsOnAll(SrcSetOfByteIncExcl,
|
||||
'3' + LE + '100' + LE, 0);
|
||||
end;
|
||||
|
||||
procedure TE2ESetOpsTests.TestRun_SetOfByte_InOperator;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertRunsOnAll(SrcSetOfByteIn,
|
||||
'1' + LE + '5' + LE + '200' + LE, 0);
|
||||
end;
|
||||
|
||||
procedure TE2ESetOpsTests.TestRun_SetOfByte_RangeLiteral;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertRunsOnAll(SrcSetOfByteRange,
|
||||
'10' + LE + '11' + LE + '12' + LE + '13' + LE + '14' + LE + '15' + LE, 0);
|
||||
end;
|
||||
|
||||
procedure TE2ESetOpsTests.TestRun_SetOfByte_Union;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertRunsOnAll(SrcSetOfByteUnion,
|
||||
'1' + LE + '2' + LE + '3' + LE, 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TE2ESetOpsTests);
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ type
|
|||
TSetTests = class(TTestCase)
|
||||
private
|
||||
function GenIR(const ASrc: string): string;
|
||||
function AnalyseSrc(const ASrc: string): TProgram;
|
||||
procedure SemanticOK(const ASrc: string);
|
||||
procedure SemanticFail(const ASrc: string);
|
||||
procedure ParseOK(const ASrc: string);
|
||||
|
|
@ -110,6 +111,25 @@ type
|
|||
procedure TestCodegen_SetLiteralArg_FoldsToBitmask;
|
||||
procedure TestCodegen_SetParam_SpillsAtWordWidth;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ set of Byte / ordinal-based sets (issue #105) }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_SetOfByte_TypeRegistered;
|
||||
procedure TestSemantic_SetOfByte_VarDecl_OK;
|
||||
procedure TestSemantic_SetOfByte_IntLiteralAssign_OK;
|
||||
procedure TestSemantic_SetOfByte_RangeLiteral_OK;
|
||||
procedure TestSemantic_SetOfByte_InOperator_OK;
|
||||
procedure TestSemantic_SetOfByte_Include_OK;
|
||||
procedure TestSemantic_SetOfByte_Exclude_OK;
|
||||
procedure TestSemantic_SetOfByte_InlineType_OK;
|
||||
procedure TestSemantic_SetOfBoolean_OK;
|
||||
procedure TestCodegen_SetOfByte_SmallLiteral_Bitmask;
|
||||
procedure TestCodegen_SetOfByte_Range_ExpandsToBitmask;
|
||||
procedure TestCodegen_SetOfByte_InOperator;
|
||||
procedure TestCodegen_SetOfByte_IncludeEmitsShlAndOr;
|
||||
procedure TestCodegen_SetOfByte_Union;
|
||||
procedure TestCodegen_SetOfByte_IsJumbo;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ 64-bit sets (>32 members) }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
@ -645,6 +665,24 @@ begin
|
|||
Prog.Free();
|
||||
end;
|
||||
|
||||
function TSetTests.AnalyseSrc(const ASrc: string): TProgram;
|
||||
var
|
||||
Lex: TLexer;
|
||||
Par: TParser;
|
||||
SA: TSemanticAnalyser;
|
||||
begin
|
||||
Lex := TLexer.Create(ASrc);
|
||||
Par := TParser.Create(Lex);
|
||||
Result := Par.Parse();
|
||||
Par.Free(); Lex.Free();
|
||||
SA := TSemanticAnalyser.Create();
|
||||
try
|
||||
SA.Analyse(Result);
|
||||
finally
|
||||
SA.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSetTests.SemanticOK(const ASrc: string);
|
||||
var
|
||||
Lex: TLexer;
|
||||
|
|
@ -1319,6 +1357,226 @@ begin
|
|||
AssertFalse('64-bit set param not spilled with storew', Pos('storew %_par_S', IR) > 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ set of Byte / ordinal-based sets (issue #105) }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
SrcSetOfByteType =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
begin
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteVar =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [1, 2, 4]
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteRange =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [1..5]
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteIn =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [1, 2, 3];
|
||||
if 2 in F then
|
||||
WriteLn('yes')
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteInclude =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [];
|
||||
Include(F, 5)
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteExclude =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [1, 2, 3];
|
||||
Exclude(F, 2)
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteInline =
|
||||
'''
|
||||
program P;
|
||||
var F: set of Byte;
|
||||
begin
|
||||
F := [10, 20]
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfBoolean =
|
||||
'''
|
||||
program P;
|
||||
type TBoolSet = set of Boolean;
|
||||
var B: TBoolSet;
|
||||
begin
|
||||
B := [True]
|
||||
end.
|
||||
''';
|
||||
|
||||
SrcSetOfByteUnion =
|
||||
'''
|
||||
program P;
|
||||
type TByteFlags = set of Byte;
|
||||
var A, B, C: TByteFlags;
|
||||
begin
|
||||
A := [1, 2];
|
||||
B := [3, 4];
|
||||
C := A + B
|
||||
end.
|
||||
''';
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_TypeRegistered;
|
||||
var
|
||||
Prog: TProgram;
|
||||
TD: TTypeDesc;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcSetOfByteType);
|
||||
try
|
||||
TD := Prog.SymbolTable.FindType('TByteFlags');
|
||||
AssertNotNull('type registered', TD);
|
||||
AssertTrue('kind is tySet', TD.Kind = tySet);
|
||||
AssertTrue('base is Byte', TSetTypeDesc(TD).BaseType.Kind = tyByte);
|
||||
AssertEquals('256 bits', 256, TSetTypeDesc(TD).BitCount);
|
||||
finally
|
||||
Prog.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_VarDecl_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteVar);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_IntLiteralAssign_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteVar);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_RangeLiteral_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteRange);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_InOperator_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteIn);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_Include_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteInclude);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_Exclude_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteExclude);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfByte_InlineType_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfByteInline);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestSemantic_SetOfBoolean_OK;
|
||||
begin
|
||||
SemanticOK(SrcSetOfBoolean);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestCodegen_SetOfByte_SmallLiteral_Bitmask;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(
|
||||
'''
|
||||
program P;
|
||||
type TSmall = set of Byte;
|
||||
var S: TSmall;
|
||||
begin
|
||||
S := [1, 3]
|
||||
end.
|
||||
''');
|
||||
AssertTrue('_SetInclude emitted for member 1',
|
||||
Pos('_SetInclude', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestCodegen_SetOfByte_Range_ExpandsToBitmask;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcSetOfByteRange);
|
||||
AssertTrue('_SetInclude emitted for range',
|
||||
Pos('_SetInclude', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestCodegen_SetOfByte_InOperator;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcSetOfByteIn);
|
||||
AssertTrue('in operator emits code', Length(IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestCodegen_SetOfByte_IncludeEmitsShlAndOr;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcSetOfByteInclude);
|
||||
AssertTrue('Include emits _SetInclude',
|
||||
Pos('_SetInclude', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestCodegen_SetOfByte_Union;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcSetOfByteUnion);
|
||||
AssertTrue('union emits code', Length(IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TSetTests.TestCodegen_SetOfByte_IsJumbo;
|
||||
var
|
||||
Prog: TProgram;
|
||||
TD: TTypeDesc;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcSetOfByteType);
|
||||
try
|
||||
TD := Prog.SymbolTable.FindType('TByteFlags');
|
||||
AssertTrue('set of Byte is jumbo', TSetTypeDesc(TD).IsJumbo());
|
||||
finally
|
||||
Prog.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TSetTests);
|
||||
|
||||
|
|
|
|||
|
|
@ -643,26 +643,29 @@ EnumMember
|
|||
* subsequent members without EQUALS continue incrementing from that value.
|
||||
* This matches Delphi and FPC semantics. *)
|
||||
|
||||
(* A set's element type is an enumeration: either a named enum type or an
|
||||
* anonymous enum written inline. Inline set types are accepted anywhere a
|
||||
* TypeName appears (var, parameter, record field, …), not only in a named
|
||||
* type declaration — e.g. var S: set of TColour; var T: set of (a, b, c);
|
||||
* The anonymous form synthesises an enum type whose members become ordinary
|
||||
* enum constants in scope. *)
|
||||
(* A set's element type is either an enumeration (named or anonymous inline)
|
||||
* or a small ordinal type (Byte, Boolean). Inline set types are accepted
|
||||
* anywhere a TypeName appears (var, parameter, record field, …), not only
|
||||
* in a named type declaration — e.g. var S: set of TColour;
|
||||
* var T: set of (a, b, c); var F: set of Byte;
|
||||
* The anonymous enum form synthesises an enum type whose members become
|
||||
* ordinary enum constants in scope. *)
|
||||
SetType
|
||||
= SET OF ( IDENT | EnumDef )
|
||||
;
|
||||
|
||||
(* The base enumeration must have at most 256 members. Storage scales with the
|
||||
* member count:
|
||||
* <= 32 members : 4 bytes, a QBE 'w' register bitmask
|
||||
* <= 64 members : 8 bytes, a QBE 'l' register bitmask
|
||||
* <= 256 members: an inline byte-array bitmap of ceil(N/8) bytes (a "jumbo"
|
||||
(* The base type must have at most 256 ordinal values. Storage scales with
|
||||
* the value count:
|
||||
* <= 32 values : 4 bytes, a QBE 'w' register bitmask
|
||||
* <= 64 values : 8 bytes, a QBE 'l' register bitmask
|
||||
* <= 256 values : an inline byte-array bitmap of ceil(N/8) bytes (a "jumbo"
|
||||
* set), operated on via the _Set* RTL helpers like an
|
||||
* aggregate (record/static array)
|
||||
* Member ordinal N maps to bit (N mod 8) of byte (N div 8) in all forms.
|
||||
* Enumerations with more than 256 members are rejected by the semantic
|
||||
* analyser (256 is the classic Pascal maximum, matching a byte-indexed set). *)
|
||||
* Value ordinal N maps to bit (N mod 8) of byte (N div 8) in all forms.
|
||||
* Types with more than 256 possible values (e.g. Integer, Word) are rejected
|
||||
* by the semantic analyser — only Byte (256 values), Boolean (2 values), and
|
||||
* enumerations with at most 256 members are accepted. Set literals with
|
||||
* ordinal base types accept integer literals and ranges: [1, 2, 10..20]. *)
|
||||
|
||||
(* Procedural type — bare or method pointer.
|
||||
*
|
||||
|
|
|
|||
|
|
@ -1293,30 +1293,60 @@ code.
|
|||
_Deferred to Phase 6 (LLVM backend + Windows target). No implementation
|
||||
required for the current Linux x86_64 target._
|
||||
|
||||
=== Set Types (`set of TEnum`)
|
||||
=== Set Types (`set of TEnum` / `set of Byte`)
|
||||
|
||||
==== Decision
|
||||
|
||||
Blaise supports Pascal bit-set types declared as `set of EnumType`, where
|
||||
`EnumType` must be a previously-defined enumeration. A set variable holds a
|
||||
bitmask in which bit N is set when the enum member with ordinal N is included.
|
||||
Blaise supports Pascal bit-set types declared as `set of BaseType`, where
|
||||
`BaseType` is either a previously-defined enumeration or one of the small
|
||||
ordinal types `Byte` (256 values, 0..255) or `Boolean` (2 values). A set
|
||||
variable holds a bitmask in which bit N is set when the member with ordinal N
|
||||
is included.
|
||||
|
||||
==== Ordinal-based sets
|
||||
|
||||
In addition to enum-based sets, Blaise supports `set of Byte` and
|
||||
`set of Boolean`. These ordinal-base sets use the same bitmap
|
||||
representation as enum sets: `set of Boolean` is a 2-bit (1-byte) small
|
||||
set, while `set of Byte` is a 256-bit (32-byte) jumbo set.
|
||||
|
||||
Set literals for ordinal-base sets accept integer literals and range
|
||||
expressions:
|
||||
|
||||
[source,pascal]
|
||||
----
|
||||
type TByteFlags = set of Byte;
|
||||
var F: TByteFlags;
|
||||
begin
|
||||
F := [1, 5, 10..20];
|
||||
Include(F, 200);
|
||||
if 15 in F then WriteLn('yes');
|
||||
end.
|
||||
----
|
||||
|
||||
Integer range expressions `[lo..hi]` are expanded to individual members at
|
||||
compile time using `EvalConstIntExpr`. Bounds are validated against the
|
||||
set's bit count (0..255 for Byte, 0..1 for Boolean).
|
||||
|
||||
Larger ordinal types (`Integer`, `Word`, `Int64`) are rejected because they
|
||||
would require impractically large bitmaps.
|
||||
|
||||
==== Storage model
|
||||
|
||||
Storage scales with the enum member count, so the common small-set case stays a
|
||||
single fast machine register and larger sets remain correct:
|
||||
Storage scales with the base type's value count, so the common small-set
|
||||
case stays a single fast machine register and larger sets remain correct:
|
||||
|
||||
- ≤ 32 enum members: a single QBE `w` (32-bit word) register bitmask.
|
||||
- 33–64 members: a single QBE `l` (64-bit long) register bitmask.
|
||||
- 65–256 members ("jumbo" sets): an inline byte-array bitmap of `ceil(N/8)`
|
||||
bytes (≤ 32 for the 256-member ceiling). QBE has no integer type wider than
|
||||
- ≤ 32 values: a single QBE `w` (32-bit word) register bitmask.
|
||||
- 33–64 values: a single QBE `l` (64-bit long) register bitmask.
|
||||
- 65–256 values ("jumbo" sets): an inline byte-array bitmap of `ceil(N/8)`
|
||||
bytes (≤ 32 for the 256-value ceiling). QBE has no integer type wider than
|
||||
`l`, so a jumbo set cannot live in one register; it is treated as a value
|
||||
aggregate (like a record or static array) — passed by reference, returned via
|
||||
sret, zero-initialised with `memset`, copied with `memcpy` — and its
|
||||
operations (`in`, `+`, `-`, `*`, `=`, `<>`, `Include`, `Exclude`, `for..in`)
|
||||
are performed by the `_Set*` RTL helpers in `blaise_set.pas` rather than
|
||||
inline register instructions.
|
||||
- More than 256 members: rejected by the semantic analyser. 256 is the classic
|
||||
- More than 256 values: rejected by the semantic analyser. 256 is the classic
|
||||
Pascal maximum — a byte-indexed set covering ordinals 0..255 — matching FPC's
|
||||
32-byte fixed-size set.
|
||||
|
||||
|
|
@ -1422,6 +1452,13 @@ the member identifiers are not in scope during the first pass.
|
|||
small enumerations (≤ 32 members). A single word is the correct choice.
|
||||
- *`not` for set complement* — deferred. Not required for current self-hosting
|
||||
targets. Can be added as a unary `not` on set operands when needed.
|
||||
- *`set of Integer`* — rejected. Integer has 2^32 possible values; a bitmap
|
||||
would require 512 MB. Only Byte (256 values) and Boolean (2 values) are
|
||||
accepted as ordinal base types alongside enumerations.
|
||||
- *Integer-literal set constants* — deferred. The `const X = [1, 2, 3]`
|
||||
parser path currently only accepts identifier (enum) members. Ordinal-base
|
||||
set literals work in var/assignment/argument context; set constants with
|
||||
integer members require parser extensions.
|
||||
|
||||
---
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue