administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

feat(lang): enforce member visibility — private/protected/strict

Browse source 
Visibility modifiers on class and record members are now enforced, not merely
parsed.  A `private` member is reachable only within the declaring unit; a
`protected` member additionally within descendant types; `public`/`published`
everywhere the type is.  Adds `strict private` and `strict protected`, which
narrow visibility to the declaring type itself (and, for strict protected, its
descendants) rather than the whole unit.  `strict` composes with `static`.

Parser: track the current visibility section in class/record bodies and the
contextual `strict` keyword (only before private/protected); carry the
visibility onto each field, method, and property declaration.  `strict public`,
`strict published`, and a bare `strict` are rejected.

Semantic: every qualified and unqualified member-access site checks visibility
via MemberVisibleTo / AssertMemberVisibleV, using the member's declaring unit
and declaring type.  Static (class-level) vars now carry Visibility and
OwnerTypeName on their TSymbol so a qualified static-var access enforces the
same rules; a strict/private static var written from another type is rejected
with a "not accessible" diagnostic.  Qualified static-var writes from a
permitted context are reported as not-yet-lowered rather than mis-resolved
(permitted writes use the unqualified form inside a static method).

Cross-unit: member visibility and declaring-type/unit origin are carried across
separately-compiled units in the .bif interface (BLAISE-IFACE version 5) so the
checks hold for imported types.

Updates docs/grammar.ebnf with the visibility-section grammar and adds
cp.test.visibility (parse + semantic enforcement) plus thread-test fixes that
switched two TThread subclasses from private FTerminated/FFinished fields to
the public Terminated/Finished properties.
This commit is contained in:
Graeme Geldenhuys 2026-06-28 23:46:52 +01:00
parent 7979f23eb1
commit a4190d73cf
15 changed files with 1282 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
compiler/src/main/pascal/uAST.pas
View file

@ -94,6 +94,10 @@ type
pmJumboSetValue { by-value jumbo (>64) set param: by-ref aggregate ABI }
);
{ TMemberVisibility is declared in uSymbolTable (so the symbol-table
descriptors can carry it without a circular unit dependency); uAST re-uses
that type for the parser-level AST member decls. }
TIdentExpr = class(TASTExpr)
public
Name: string;
@ -148,6 +152,12 @@ type
IsClassVarRead: Boolean; { set by uSemantic — TypeName.StaticVar read; lower as a global load of ClassVarEmitName }
ClassVarEmitName: string; { mangled global label for an IsClassVarRead access }
IsStaticPropGet: Boolean; { set by uSemantic — TypeName.StaticProp read; ResolvedMethod is the static getter }
BackingFieldRedirect: Boolean; { set by uSemantic — FieldName was rewritten from a
property name to its (possibly private) backing
field; visibility was already enforced on the
property, so re-analysis of this node must NOT
re-check the backing field's visibility. Transient
analysis flag — not serialised. }
destructor Destroy; override;
end;
@ -749,6 +759,9 @@ type
BOTH backends emit the slot under the exact label
the read/write sites use, without re-deriving the
unit prefix. }
Visibility: TMemberVisibility; { set by uParser from the enclosing visibility
section; default mvPublic. Enforced by
uSemantic's member-access checks. }
constructor Create;
destructor Destroy; override;
end;
@ -874,6 +887,8 @@ type
implementation section (no interface forward). Such routines are
PRIVATE to the unit; overload resolution must not treat another
unit's same-named impl-only routine as a competing candidate. }
Visibility: TMemberVisibility; { set by uParser from the enclosing visibility section
when this is a class/record method; default mvPublic. }
constructor Create;
destructor Destroy; override;
end;
@ -913,6 +928,8 @@ type
IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) }
IsStatic: Boolean; { set by uParser — declared `static`: sugar over a
static getter/setter; no implicit Self. }
Visibility: TMemberVisibility; { set by uParser from the enclosing visibility
section; default mvPublic. }
end;
TClassTypeDef = class(TASTTypeDef)
@ -2278,6 +2295,10 @@ begin
Result.IsUnretained := ASrc.IsUnretained;
Result.IsClassVar := ASrc.IsClassVar;
Result.ClassVarEmitName := ASrc.ClassVarEmitName;
{ Visibility must survive the export clone or a cross-unit consumer would see
every imported field as public and enforcement would silently disappear at
the unit boundary. }
Result.Visibility := ASrc.Visibility;
end;
function ClonePropertyDecl(ASrc: TPropertyDecl): TPropertyDecl;
@ -2293,6 +2314,7 @@ begin
property whose accessors take no Self. Both were silently dropped. }
Result.IsDefault := ASrc.IsDefault;
Result.IsStatic := ASrc.IsStatic;
Result.Visibility := ASrc.Visibility;
end;
function CloneTypeDecl(ASrc: TTypeDecl): TTypeDecl;
@ -2411,6 +2433,7 @@ begin
export clone made every cross-unit static method look like a normal
instance method, so TypeName.StaticMethod() resolution failed. }
Result.IsStatic := ASrc.IsStatic;
Result.Visibility := ASrc.Visibility;
for I := 0 to ASrc.Params.Count - 1 do
Result.Params.Add(CloneMethodParam(TMethodParam(ASrc.Params.Items[I])));
if ASrc.TypeParams <> nil then

112
compiler/src/main/pascal/uParser.pas
View file

@ -1927,12 +1927,14 @@ function TParser.ParseRecordDef: TRecordTypeDef;
var
MethDecl: TMethodDecl;
CurrStatic: Boolean; { current section's static (class-level) association }
CurrVisibility: TMemberVisibility; { current section's visibility }
LocalStatic: Boolean;
FieldCountBefore: Integer;
FieldIdx: Integer;
begin
Result := TRecordTypeDef.Create();
CurrStatic := False;
CurrStatic := False;
CurrVisibility := mvPublic;
try
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
@ -1947,12 +1949,45 @@ begin
CurrStatic := True;
Advance(); { the following var/const section belongs to this static section }
end
{ Visibility section keywords are accepted (and currently cosmetic), with
an optional trailing `static`. A new visibility section resets static. }
{ Optional `strict` soft keyword before private/protected (record fields). }
else if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
(PeekKind() = tkIdent) and
(SameText(PeekValueAt(1), 'private') or
SameText(PeekValueAt(1), 'protected')) then
begin
Advance(); { consume `strict` }
if SameText(FCurrent.Value, 'private') then
CurrVisibility := mvStrictPrivate
else
CurrVisibility := mvStrictProtected;
CurrStatic := False;
Advance(); { consume private/protected }
if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
(PeekKind() in [tkVar, tkConst, tkFunction, tkProcedure]) then
begin
CurrStatic := True;
Advance();
end;
end
else if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
(PeekKind() = tkIdent) and
(SameText(PeekValueAt(1), 'public') or
SameText(PeekValueAt(1), 'published')) then
raise EParseError.Create(Format(
'Only ''private'' or ''protected'' may be ''strict'' at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]))
{ Visibility section keywords, with an optional trailing `static`.
A new visibility section resets static. }
else if Check(tkIdent) and (SameText(FCurrent.Value, 'private') or
SameText(FCurrent.Value, 'public') or
SameText(FCurrent.Value, 'protected')) then
begin
if SameText(FCurrent.Value, 'private') then
CurrVisibility := mvPrivate
else if SameText(FCurrent.Value, 'protected') then
CurrVisibility := mvProtected
else
CurrVisibility := mvPublic;
CurrStatic := False;
Advance();
if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
@ -1983,15 +2018,19 @@ begin
else
MethDecl := ParseMethodDecl(False);
MethDecl.IsStatic := LocalStatic;
MethDecl.Visibility := CurrVisibility;
Result.Methods.Add(MethDecl);
end
else if Check(tkIdent) or Check(tkLBracket) then
begin
FieldCountBefore := Result.Fields.Count;
ParseFieldDecl(Result.Fields);
if CurrStatic then
for FieldIdx := FieldCountBefore to Result.Fields.Count - 1 do
for FieldIdx := FieldCountBefore to Result.Fields.Count - 1 do
begin
if CurrStatic then
TFieldDecl(Result.Fields.Items[FieldIdx]).IsClassVar := True;
TFieldDecl(Result.Fields.Items[FieldIdx]).Visibility := CurrVisibility;
end;
end
else
Break;
@ -2037,6 +2076,7 @@ end;
function TParser.ParseClassDef: TClassTypeDef;
var
CurrPublished: Boolean;
CurrVisibility: TMemberVisibility; { current section's visibility }
CurrStatic: Boolean; { current section's static (class-level) association }
LocalStatic: Boolean; { effective static for the member being parsed }
MethDecl: TMethodDecl;
@ -2077,18 +2117,63 @@ begin
(private/public/protected/published) update CurrPublished, which
is then attached to each method decl so codegen can emit a
published-method table entry. }
CurrPublished := False;
CurrStatic := False;
CurrPublished := False;
CurrVisibility := mvPublic;
CurrStatic := False;
repeat
{ Optional `strict` soft keyword preceding `private`/`protected`. `strict`
is not a real token — recognise it only at section start, immediately
before `private` or `protected`, so an ordinary identifier named `strict`
elsewhere is unaffected. `strict public`, `strict published` and bare
`strict` are errors. }
if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
(PeekKind() = tkIdent) and
(SameText(PeekValueAt(1), 'private') or
SameText(PeekValueAt(1), 'protected')) then
begin
Advance(); { consume `strict`; the following private/protected sets visibility }
if SameText(FCurrent.Value, 'private') then
CurrVisibility := mvStrictPrivate
else
CurrVisibility := mvStrictProtected;
CurrPublished := False;
CurrStatic := False;
Advance(); { consume the private/protected keyword }
{ Optional trailing `static` section qualifier — `strict private static var`. }
if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
((PeekKind() in [tkVar, tkConst, tkFunction, tkProcedure,
tkConstructor, tkDestructor]) or
((PeekKind() = tkIdent) and SameText(PeekValueAt(1), 'property'))) then
begin
CurrStatic := True;
Advance();
end;
end
{ `strict` not followed by private/protected is an error inside a class body. }
else if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
(PeekKind() = tkIdent) and
(SameText(PeekValueAt(1), 'public') or
SameText(PeekValueAt(1), 'published')) then
raise EParseError.Create(Format(
'Only ''private'' or ''protected'' may be ''strict'' at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]))
{ Visibility section keyword (private/public/protected/published),
optionally followed by a `static` qualifier. A visibility keyword
resets the static section (you must re-state `static` after it). }
if Check(tkIdent) and (SameText(FCurrent.Value, 'private') or
else if Check(tkIdent) and (SameText(FCurrent.Value, 'private') or
SameText(FCurrent.Value, 'public') or
SameText(FCurrent.Value, 'protected') or
SameText(FCurrent.Value, 'published')) then
begin
CurrPublished := SameText(FCurrent.Value, 'published');
if SameText(FCurrent.Value, 'private') then
CurrVisibility := mvPrivate
else if SameText(FCurrent.Value, 'protected') then
CurrVisibility := mvProtected
else if SameText(FCurrent.Value, 'published') then
CurrVisibility := mvPublished
else
CurrVisibility := mvPublic;
CurrStatic := False; { a new visibility section is non-static unless
`static` follows }
Advance(); { consume the visibility modifier }
@ -2135,6 +2220,7 @@ begin
end;
PropDecl := ParsePropertyDecl();
PropDecl.IsStatic := LocalStatic;
PropDecl.Visibility := CurrVisibility;
Result.Properties.Add(PropDecl);
end
{ Method declarations — checked BEFORE the generic field branch so that a
@ -2166,16 +2252,20 @@ begin
MethDecl := ParseMethodDecl(False);
MethDecl.IsPublished := CurrPublished;
MethDecl.IsStatic := LocalStatic;
MethDecl.Visibility := CurrVisibility;
Result.Methods.Add(MethDecl);
end
else if Check(tkIdent) or Check(tkLBracket) then
begin
FieldCountBefore := Result.Fields.Count;
ParseFieldDecl(Result.Fields);
{ Stamp class-var flag on every field this decl produced. }
if CurrStatic then
for FieldIdx := FieldCountBefore to Result.Fields.Count - 1 do
{ Stamp class-var flag and visibility on every field this decl produced. }
for FieldIdx := FieldCountBefore to Result.Fields.Count - 1 do
begin
if CurrStatic then
TFieldDecl(Result.Fields.Items[FieldIdx]).IsClassVar := True;
TFieldDecl(Result.Fields.Items[FieldIdx]).Visibility := CurrVisibility;
end;
end
else
Break;

251
compiler/src/main/pascal/uSemantic.pas
View file

@ -519,6 +519,29 @@ type
const AMemberName: string;
ALine, ACol: Integer);
{ Core visibility predicate. Single source of truth applied by both
the unqualified uses-chain probe and the qualified member-access
asserts. ADeclaringUnit / ADeclaringType identify where the member
was declared; AFromClass is the class whose method body we are in
(or nil at unit/free-routine level). }
function MemberVisibleTo(AVisibility: TMemberVisibility;
const ADeclaringUnit, ADeclaringType: string;
const AFromUnit: string;
AFromClass: TRecordTypeDesc): Boolean;
{ Richer qualified-access assert that carries the member's visibility
and declaring type. On invisible, hard error. }
procedure AssertMemberVisibleV(AVisibility: TMemberVisibility;
const ADeclaringUnit, ADeclaringType: string;
const AMemberName: string;
ALine, ACol: Integer);
{ Qualified instance/class method-call visibility enforcement. AMDecl is
the resolved TMethodDecl (via ResolveMethodOverload or FindMethodDecl);
reads its Visibility / OwningUnit / OwnerTypeName. No-op when AMDecl is
nil. Constructors are exempt (always reachable for instantiation). }
procedure EnforceMethodVisible(AMDecl: TObject; ALine, ACol: Integer);
{ Uses-chain lookup for *unqualified* identifiers. Walks
FCurrentUsesChain right-to-left ("last in uses wins"); for
each chain entry whose TUnitInterface advertises AName via
@ -2018,13 +2041,10 @@ function TSemanticAnalyser.IsVisibleFromUnit(ASym: TSymbol;
const AFromUnit: string;
AFromClass: TRecordTypeDesc): Boolean;
begin
{ Stub — see declaration in interface section. When private/
protected modifiers arrive on class members:
- private: Result := (AFromUnit = ASym.OwningUnit);
- protected: Result := (AFromUnit = ASym.OwningUnit)
or (AFromClass <> nil)
and AFromClassDescendsFromDeclarer(...);
Free symbols default to public so AFromClass is ignored for them. }
{ Free (non-member) symbols default to public — the symbol carries no
per-member visibility, so the uses-chain probe never rejects on this
path. Class/record member visibility is enforced at the qualified- and
unqualified-member access sites via MemberVisibleTo / AssertMemberVisibleV. }
Result := True;
end;
@ -2032,16 +2052,78 @@ function TSemanticAnalyser.IsVisibleFromUnit(const AMemberOwningUnit: string;
const AFromUnit: string;
AFromClass: TRecordTypeDesc): Boolean;
begin
{ String-flavor stub. Same future logic as the TSymbol form,
keyed on the AMemberOwningUnit string directly. }
{ String-flavor — same rationale as the TSymbol form. }
Result := True;
end;
function TSemanticAnalyser.MemberVisibleTo(AVisibility: TMemberVisibility;
const ADeclaringUnit, ADeclaringType: string;
const AFromUnit: string;
AFromClass: TRecordTypeDesc): Boolean;
var
C: TRecordTypeDesc;
begin
case AVisibility of
mvPublic, mvPublished:
Result := True;
mvPrivate:
{ Unit-scoped: visible to any code in the declaring unit. A member
whose declaring unit is unknown (empty) is treated as same-unit —
program-scope types and pre-visibility imports must not be locked out. }
Result := (ADeclaringUnit = '') or SameText(ADeclaringUnit, AFromUnit);
mvProtected:
begin
{ Same unit OR AFromClass is the declaring type or a descendant of it. }
Result := (ADeclaringUnit = '') or SameText(ADeclaringUnit, AFromUnit);
if not Result then
begin
C := AFromClass;
while C <> nil do
begin
if SameText(C.Name, ADeclaringType) then
begin
Result := True;
Break;
end;
C := C.Parent;
end;
end;
end;
mvStrictPrivate:
{ Visible only from the declaring TYPE's own methods. }
Result := (AFromClass <> nil) and SameText(AFromClass.Name, ADeclaringType);
mvStrictProtected:
begin
{ Declaring type or any descendant's methods, regardless of unit. }
Result := False;
C := AFromClass;
while C <> nil do
begin
if SameText(C.Name, ADeclaringType) then
begin
Result := True;
Break;
end;
C := C.Parent;
end;
end;
else
Result := True;
end;
end;
procedure TSemanticAnalyser.AssertMemberVisible(const AMemberOwningUnit: string;
AClassContext: TRecordTypeDesc;
const AMemberName: string;
ALine, ACol: Integer);
begin
{ Legacy unit-only assert — no per-member visibility available here, so it
never rejects. Retained for call sites that lack the descriptor; the
visibility-bearing AssertMemberVisibleV does the real enforcement. }
if not IsVisibleFromUnit(AMemberOwningUnit, FCurrentUnitName, AClassContext) then
SemanticError(
Format('Identifier ''%s'' is not accessible from this context',
@ -2049,6 +2131,32 @@ begin
ALine, ACol);
end;
procedure TSemanticAnalyser.EnforceMethodVisible(AMDecl: TObject;
ALine, ACol: Integer);
var
M: TMethodDecl;
begin
if AMDecl = nil then Exit;
M := TMethodDecl(AMDecl);
{ A constructor is always reachable (you must be able to instantiate the
type); enforcing visibility on Create would block legitimate construction. }
if SameText(M.Name, 'Create') then Exit;
AssertMemberVisibleV(M.Visibility, M.OwningUnit, M.OwnerTypeName,
M.Name, ALine, ACol);
end;
procedure TSemanticAnalyser.AssertMemberVisibleV(AVisibility: TMemberVisibility;
const ADeclaringUnit, ADeclaringType: string;
const AMemberName: string;
ALine, ACol: Integer);
begin
if not MemberVisibleTo(AVisibility, ADeclaringUnit, ADeclaringType,
FCurrentUnitName, FCurrentClass) then
SemanticError(
Format('''%s'' is not accessible from here', [AMemberName]),
ALine, ACol);
end;
procedure TSemanticAnalyser.LinkClassMethodImpls(ABlock: TBlock);
var
I, J, K: Integer;
@ -3050,6 +3158,7 @@ begin
for J := 0 to FDecl.Names.Count - 1 do
NewFDecl.Names.Add(FDecl.Names.Strings[J]);
NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args);
NewFDecl.Visibility := FDecl.Visibility;
ClonedCD.Fields.Add(NewFDecl);
end;
@ -3066,6 +3175,7 @@ begin
NewMDecl.OwnerTypeName := ATypeName;
NewMDecl.IsVirtual := MDecl.IsVirtual;
NewMDecl.IsOverride := MDecl.IsOverride;
NewMDecl.Visibility := MDecl.Visibility;
if (MDecl.Body <> nil) and (not DeferBodies) then
begin
NewMDecl.Body := CloneBlock(MDecl.Body);
@ -3108,6 +3218,7 @@ begin
NewPDecl.IndexParamName := PDecl.IndexParamName;
NewPDecl.IndexTypeName := SubstTypeParam(PDecl.IndexTypeName, Templ.ParamNames, Args);
NewPDecl.IsDefault := PDecl.IsDefault;
NewPDecl.Visibility := PDecl.Visibility;
ClonedCD.Properties.Add(NewPDecl);
end;
@ -3131,6 +3242,9 @@ begin
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
RT.FindField(FldInfo.Name).IsUnretained := FldInfo.IsUnretained;
RT.FindField(FldInfo.Name).IsWeak := FldInfo.IsWeak;
RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
end
@ -3181,6 +3295,9 @@ begin
begin
FldName := NewFDecl.Names.Strings[K];
RT.AddField(FldName, FldType);
RT.FindField(FldName).Visibility := NewFDecl.Visibility;
RT.FindField(FldName).DeclaringUnit := FCurrentUnitName;
RT.FindField(FldName).DeclaringType := ATypeName;
end;
end;
@ -3272,6 +3389,9 @@ begin
PropInfo.IndexTypeDesc := FindTypeOrInstantiate(NewPDecl.IndexTypeName);
PropInfo.IsDefault := NewPDecl.IsDefault;
PropInfo.IsStatic := NewPDecl.IsStatic;
PropInfo.Visibility := NewPDecl.Visibility;
PropInfo.DeclaringUnit := FCurrentUnitName;
PropInfo.DeclaringType := ATypeName;
RT.AddProperty(PropInfo);
end;
@ -3413,6 +3533,7 @@ begin
for J := 0 to FDecl.Names.Count - 1 do
NewFDecl.Names.Add(FDecl.Names.Strings[J]);
NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args);
NewFDecl.Visibility := FDecl.Visibility;
ClonedRD.Fields.Add(NewFDecl);
end;
@ -3423,6 +3544,7 @@ begin
NewMDecl.Name := MDecl.Name;
NewMDecl.OwnerTypeName := ATypeName;
NewMDecl.IsRecordMethod := True;
NewMDecl.Visibility := MDecl.Visibility;
if (MDecl.Body <> nil) and (not DeferBodies) then
begin
NewMDecl.Body := CloneBlock(MDecl.Body);
@ -3465,6 +3587,9 @@ begin
begin
FldName := NewFDecl.Names.Strings[K];
RT.AddField(FldName, FldType);
RT.FindField(FldName).Visibility := NewFDecl.Visibility;
RT.FindField(FldName).DeclaringUnit := FCurrentUnitName;
RT.FindField(FldName).DeclaringType := ATypeName;
end;
end;
@ -5362,6 +5487,12 @@ begin
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
RT.FindField(FldInfo.Name).IsUnretained := FldInfo.IsUnretained;
RT.FindField(FldInfo.Name).IsWeak := FldInfo.IsWeak;
{ An inherited field keeps the ANCESTOR's visibility + declaring
origin — protected/strict checks must resolve against where the
field was actually declared, not the subclass that copied it. }
RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
end;
@ -5552,12 +5683,16 @@ begin
Sym.IsGlobal := True;
Sym.IsClassVar := True;
Sym.GlobalEmitName := ClassVarEmit;
Sym.Visibility := FDecl.Visibility;
Sym.OwnerTypeName := TD.Name;
if not FTable.Define(Sym) then Sym.Free();
{ Qualified name — usable as TFoo.Name from anywhere. }
Sym := TSymbol.Create(TD.Name + '.' + FldName, skVariable, FldType);
Sym.IsGlobal := True;
Sym.IsClassVar := True;
Sym.GlobalEmitName := ClassVarEmit;
Sym.Visibility := FDecl.Visibility;
Sym.OwnerTypeName := TD.Name;
if not FTable.Define(Sym) then Sym.Free();
end
else
@ -5570,6 +5705,13 @@ begin
RT.FindField(FldName).IsWeak := True;
if FDecl.IsUnretained then
RT.FindField(FldName).IsUnretained := True;
{ Carry visibility + declaring origin so member-access checks can be
applied without re-walking the AST. DeclaringType is this class
(the one that declares the field); inherited fields copy the
ancestor's metadata at the copy site above. }
RT.FindField(FldName).Visibility := FDecl.Visibility;
RT.FindField(FldName).DeclaringUnit := FCurrentUnitName;
RT.FindField(FldName).DeclaringType := TD.Name;
end;
end;
end;
@ -5580,6 +5722,11 @@ begin
begin
MDecl := TMethodDecl(MethodList.Items[J]);
MDecl.OwnerTypeName := TD.Name;
{ Stamp the declaring unit so member-visibility (private/protected) can
enforce the unit privacy boundary. Only set when empty so a value
carried from an imported .bif is not overwritten. }
if MDecl.OwningUnit = '' then
MDecl.OwningUnit := FCurrentUnitName;
{ Compute mangled key and ResolvedQbeName for overloaded methods.
Non-overloaded methods keep their plain name throughout. }
@ -5666,6 +5813,9 @@ begin
PropInfo.IndexTypeDesc := FTable.FindType(PropDecl.IndexTypeName);
PropInfo.IsDefault := PropDecl.IsDefault;
PropInfo.IsStatic := PropDecl.IsStatic;
PropInfo.Visibility := PropDecl.Visibility;
PropInfo.DeclaringUnit := FCurrentUnitName;
PropInfo.DeclaringType := TD.Name;
RT.AddProperty(PropInfo);
end;
@ -5965,7 +6115,6 @@ var
Key: string;
Sym: TSymbol;
RT: TRecordTypeDesc;
OwnerUnit: string;
begin
CurrName := ATypeName;
while CurrName <> '' do
@ -5975,13 +6124,11 @@ begin
if Idx >= 0 then
begin
Result := TMethodDecl(FMethodIndex.Objects[Idx]);
{ Visibility seam: treat the class's owning unit as the member's
effective owner. Currently a no-op (returns True); activates
without call-site work when class members gain private/protected. }
OwnerUnit := '';
Sym := FTable.Lookup(CurrName);
if Sym <> nil then OwnerUnit := Sym.OwningUnit;
AssertMemberVisible(OwnerUnit, FCurrentClass, AMethodName, 0, 0);
{ Visibility is NOT enforced here: FindMethodDecl is also used to resolve
property getters/setters, Free/Create existence probes, and inherited
lookups, where the access is legitimate regardless of the member's
declared visibility. Enforcement happens at the user-written call /
member-access sites (EnforceMethodVisible / AssertMemberVisibleV). }
Exit;
end;
{ Walk to parent }
@ -7695,6 +7842,7 @@ begin
[RT.Name, ACall.Name]),
ACall.Line, ACall.Col);
AppendDefaultArgs(ACall.Args, MDecl, ACall.Name, ACall.Line, ACall.Col);
EnforceMethodVisible(MDecl, ACall.Line, ACall.Col);
ACall.ResolvedClassType := RT;
ACall.ResolvedMethod := MDecl;
ACall.IsStaticCall := True;
@ -7862,6 +8010,7 @@ begin
ACall.Line, ACall.Col);
AppendDefaultArgs(ACall.Args, MDecl, ACall.Name, ACall.Line, ACall.Col);
EnforceMethodVisible(MDecl, ACall.Line, ACall.Col);
ACall.ResolvedClassType := RT;
ACall.ResolvedMethod := MDecl;
ACall.IsGlobal := ObjSym.IsGlobal;
@ -8252,6 +8401,7 @@ var
ExprType: TTypeDesc;
ObjType: TTypeDesc;
IntfDesc: TInterfaceTypeDesc;
VarSym: TSymbol;
begin
{ ObjExpr path: receiver is an arbitrary expression (e.g. typecast result) }
if AAssign.ObjExpr <> nil then
@ -8267,6 +8417,10 @@ begin
if FldInfo = nil then
begin
PropInfo := RT.FindProperty(AAssign.FieldName);
if PropInfo <> nil then
AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
PropInfo.DeclaringType, AAssign.FieldName,
AAssign.Line, AAssign.Col);
if (PropInfo <> nil) and (PropInfo.WriteField <> '') then
begin
AAssign.FieldName := PropInfo.WriteField;
@ -8276,7 +8430,11 @@ begin
SemanticError(
Format('Type ''%s'' has no field ''%s''', [ObjType.Name, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
end;
end
else
AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
FldInfo.DeclaringType, AAssign.FieldName,
AAssign.Line, AAssign.Col);
AAssign.IsClassAccess := ObjType.Kind = tyClass;
AAssign.FieldInfo := FldInfo;
if TryAnalyseFieldElemWrite(AAssign, FldInfo) then
@ -8358,6 +8516,30 @@ begin
Format('Undeclared variable ''%s''', [AAssign.RecordName]),
AAssign.Line, AAssign.Col);
end;
{ Qualified STATIC (class-level) variable write: 'TFoo.StaticVar := V'.
RecordName is a class/record TYPE, not a variable; the static var was
registered under the combined key 'TFoo.StaticVar'. Enforce member
visibility first (this is where a strict/private static var written from
another type is rejected with a "not accessible" diagnostic). The write
itself from a PERMITTED context still lowers through the bare static-var
path (a method writes 'StaticVar := V' unqualified); the qualified write
form is not yet lowered by codegen, so report it cleanly rather than emit a
bare 'is not a variable'. }
if RecSym.Kind = skType then
begin
VarSym := FTable.Lookup(AAssign.RecordName + '.' + AAssign.FieldName);
if (VarSym <> nil) and (VarSym.Kind = skVariable) and VarSym.IsClassVar then
begin
AssertMemberVisibleV(VarSym.Visibility, VarSym.OwningUnit,
VarSym.OwnerTypeName, AAssign.FieldName,
AAssign.Line, AAssign.Col);
SemanticError(Format(
'Qualified write to static var ''%s.%s'' is not yet supported; assign ' +
'it from a static method of ''%s'' using the unqualified name',
[AAssign.RecordName, AAssign.FieldName, AAssign.RecordName]),
AAssign.Line, AAssign.Col);
end;
end;
if not (RecSym.Kind in [skVariable, skParameter, skVarParameter]) then
SemanticError(
Format('''%s'' is not a variable', [AAssign.RecordName]),
@ -8411,6 +8593,9 @@ begin
PropInfo := RT.FindProperty(AAssign.FieldName);
if PropInfo <> nil then
begin
AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
PropInfo.DeclaringType, AAssign.FieldName,
AAssign.Line, AAssign.Col);
if PropInfo.WriteField <> '' then
begin
{ Field-backed write: redirect to the backing field }
@ -8451,7 +8636,12 @@ begin
Format('Type ''%s'' has no field ''%s''',
[AAssign.RecordName, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
end;
end
else
{ Field write via variable.Field — enforce visibility. }
AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
FldInfo.DeclaringType, AAssign.FieldName,
AAssign.Line, AAssign.Col);
AAssign.FieldInfo := FldInfo;
if TryAnalyseFieldElemWrite(AAssign, FldInfo) then
@ -10582,6 +10772,7 @@ begin
[ObjSym.Name, AExpr.Name]),
AExpr.Line, AExpr.Col);
AppendDefaultArgs(AExpr.Args, MDecl, AExpr.Name, AExpr.Line, AExpr.Col);
EnforceMethodVisible(MDecl, AExpr.Line, AExpr.Col);
AExpr.ResolvedMethod := MDecl;
AExpr.ResolvedClassType := ObjSym.TypeDesc;
AExpr.IsStaticCall := True;
@ -10810,6 +11001,7 @@ begin
AExpr.Line, AExpr.Col);
end;
EnforceMethodVisible(MDecl, AExpr.Line, AExpr.Col);
AExpr.ResolvedClassType := RT;
AExpr.ResolvedMethod := MDecl;
AExpr.IsGlobal := ObjSym.IsGlobal;
@ -11100,6 +11292,10 @@ begin
if FldInfo = nil then
begin
PropInfo := RT.FindProperty(AAccess.FieldName);
if PropInfo <> nil then
AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
PropInfo.DeclaringType, AAccess.FieldName,
AAccess.Line, AAccess.Col);
if (PropInfo <> nil) and (PropInfo.ReadField <> '') then
begin
Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
@ -11107,6 +11303,7 @@ begin
Exit;
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
AAccess.BackingFieldRedirect := True;
Exit(PropInfo.TypeDesc);
end;
{ Method-backed property (including indexed: the parser attaches the
@ -11167,6 +11364,12 @@ begin
[BaseType.Name, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
end;
{ Field found via qualified access (Base.Field) — enforce visibility unless
this node is a property→backing-field redirect already checked. }
if not AAccess.BackingFieldRedirect then
AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
FldInfo.DeclaringType, AAccess.FieldName,
AAccess.Line, AAccess.Col);
AAccess.FieldInfo := FldInfo;
Result := FldInfo.TypeDesc;
if AAccess.PropIndexExpr <> nil then
@ -11546,6 +11749,9 @@ begin
PropInfo := RT.FindProperty(AAccess.FieldName);
if PropInfo <> nil then
begin
AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
PropInfo.DeclaringType, AAccess.FieldName,
AAccess.Line, AAccess.Col);
if PropInfo.ReadField <> '' then
begin
{ Field-backed read: redirect to the backing field }
@ -11554,6 +11760,7 @@ begin
Exit;
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
AAccess.BackingFieldRedirect := True;
Result := PropInfo.TypeDesc;
AAccess.ResolvedType := Result;
Exit;
@ -11610,6 +11817,12 @@ begin
AAccess.Line, AAccess.Col);
end;
{ Field found via variable.Field qualified access — enforce visibility unless
this node is a property→backing-field redirect already checked. }
if not AAccess.BackingFieldRedirect then
AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
FldInfo.DeclaringType, AAccess.FieldName,
AAccess.Line, AAccess.Col);
AAccess.FieldInfo := FldInfo;
Result := FldInfo.TypeDesc;
if AAccess.PropIndexExpr <> nil then

2
compiler/src/main/pascal/uSemanticExport.pas
View file

@ -234,6 +234,8 @@ begin
VTableSlot alone cannot distinguish a static method from a final
non-virtual instance method (both are -1). }
Result.IsStatic := ASrc.IsStatic;
{ Carry visibility so cross-unit member access enforces private/protected. }
Result.Visibility := ASrc.Visibility;
Result.ReturnType := ResolveTypeRef(ASrc.ReturnTypeName, AIface, ADeps);
for I := 0 to ASrc.Params.Count - 1 do

22
compiler/src/main/pascal/uSemanticImport.pas
View file

@ -529,6 +529,10 @@ begin
begin
FldInfo := TFieldInfo(ParentRT.Fields.Items[I]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
{ Inherited field keeps the ancestor's visibility + declaring origin. }
RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
@ -551,7 +555,15 @@ begin
FldDecl.ClassVarEmitName, FldType, ATable)
else
for J := 0 to FldDecl.Names.Count - 1 do
begin
RT.AddField(FldDecl.Names.Strings[J], FldType);
{ An imported field's privacy boundary is its own declaring unit, not
the importing unit — carry both so cross-unit private/protected is
enforced exactly as in the declaring unit. }
RT.FindField(FldDecl.Names.Strings[J]).Visibility := FldDecl.Visibility;
RT.FindField(FldDecl.Names.Strings[J]).DeclaringUnit := AUnitName;
RT.FindField(FldDecl.Names.Strings[J]).DeclaringType := AEntry.Name;
end;
end;
{ Methods: walk TRoutineSig list; for virtual/override, register
@ -631,6 +643,9 @@ begin
implicit Self. Mirrors the within-unit pass (PropInfo.IsStatic). }
PropInfo.IsDefault := PropDecl.IsDefault;
PropInfo.IsStatic := PropDecl.IsStatic;
PropInfo.Visibility := PropDecl.Visibility;
PropInfo.DeclaringUnit := AUnitName;
PropInfo.DeclaringType := AEntry.Name;
RT.AddProperty(PropInfo);
end;
@ -699,7 +714,12 @@ begin
FldDecl.ClassVarEmitName, FldType, ATable)
else
for J := 0 to FldDecl.Names.Count - 1 do
begin
RecDesc.AddField(FldDecl.Names.Strings[J], FldType);
RecDesc.FindField(FldDecl.Names.Strings[J]).Visibility := FldDecl.Visibility;
RecDesc.FindField(FldDecl.Names.Strings[J]).DeclaringUnit := AUnitName;
RecDesc.FindField(FldDecl.Names.Strings[J]).DeclaringType := AEntry.Name;
end;
end;
{ record-level `static const` declarations — reachable bare and qualified. }
@ -961,6 +981,8 @@ begin
{ Carry static-ness so the semantic pass's TypeName.StaticMethod() resolution
(which checks MDecl.IsStatic) succeeds for a method imported from a .bif. }
Result.IsStatic := ASig.IsStatic;
{ Carry visibility so cross-unit private/protected method access is enforced. }
Result.Visibility := ASig.Visibility;
for J := 0 to ASig.Params.Count - 1 do
begin
Param := TMethodParam(ASig.Params.Items[J]);

40
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -14,6 +14,28 @@ uses
Classes, SysUtils, contnrs;
type
{ Member visibility — class/record field, method, and property access scope.
Default (a member declared before any visibility keyword) is mvPublic, to
match Blaise's previous behaviour where visibility was parsed but never
enforced (everything was effectively public).
mvPublic / mvPublished — visible everywhere the type is.
mvPrivate — visible only within the declaring UNIT
(classic Pascal unit-scoped privacy).
mvProtected — as mvPrivate plus descendant types' methods,
regardless of unit.
mvStrictPrivate — visible only from the declaring TYPE's methods.
mvStrictProtected — declaring type plus its descendants' methods.
Declared here (not in uAST) so the symbol-table descriptors can carry it;
uAST uses uSymbolTable, so the type flows up to the AST member decls. }
TMemberVisibility = (
mvPublic,
mvPrivate,
mvProtected,
mvPublished,
mvStrictPrivate,
mvStrictProtected
);
{ ------------------------------------------------------------------ }
{ Type descriptors }
{ ------------------------------------------------------------------ }
@ -196,6 +218,13 @@ type
with neither addref nor release, and field cleanup
does nothing. Use only when the referent is
guaranteed to outlive this field. }
Visibility: TMemberVisibility; { access scope; default mvPublic }
DeclaringUnit: string; { name of the unit that declares the owning type — the
privacy boundary for mvPrivate/mvProtected }
DeclaringType: string; { name of the class/record that DECLARED this field; for
an inherited field this is the ancestor, not the
subclass that copied it — protected/strict checks walk
the descendant chain up to this type }
end;
{ One entry in a class vtable — tracks slot index and implementing method. }
@ -220,6 +249,9 @@ type
[Unretained] IndexTypeDesc: TTypeDesc; { not owned; non-nil when IndexParamName <> '' }
IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) }
IsStatic: Boolean; { declared `static property` — accessors are static (no Self) }
Visibility: TMemberVisibility; { access scope; default mvPublic }
DeclaringUnit: string; { unit that declares the owning type — privacy boundary }
DeclaringType: string; { class/record that DECLARED this property (ancestor for inherited) }
end;
{ Type descriptor for zero-GUID interface types (Phase 3). }
@ -402,6 +434,14 @@ type
not the owner. Prevents an impl-section class/
type from leaking into an unrelated unit through
the flat global scope. }
Visibility: TMemberVisibility; { for a STATIC (class-level) variable: the
declared member visibility (private/protected/
strict/public). Default mvPublic. Read by the
qualified-access visibility checks. }
OwnerTypeName: string; { for a STATIC (class-level) variable: the class/
record that declared it. Empty for non-members.
Lets strict/protected checks resolve the owning
type the same way TFieldInfo.DeclaringType does. }
constructor Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc);
destructor Destroy; override;
end;

1
compiler/src/main/pascal/uUnitInterface.pas
View file

@ -94,6 +94,7 @@ type
static and final non-virtual instance
methods, so this is a distinct flag rather
than being inferred from the slot. }
Visibility: TMemberVisibility; { member access scope; default mvPublic }
constructor Create;
destructor Destroy; override;
end;

31
compiler/src/main/pascal/uUnitInterfaceIO.pas
View file

@ -53,7 +53,12 @@ uses
const
IFACE_MAGIC = 'BLAISE-IFACE';
IFACE_VERSION = 4; { v4 (this cycle): TRoutineSig.IsStatic added to
IFACE_VERSION = 5; { v5 (this cycle): member Visibility (private/protected/
strict) now serialised — field, method, and property
payloads each carry one extra byte for the visibility
ordinal, so v4 readers must reject these .bif and
recompile.
v4: TRoutineSig.IsStatic added to
EncodeMethodSig/ReadMethodSig so a cross-unit
TypeName.StaticMethod() call resolves through the
cached .bif (VTableSlot alone cannot distinguish a
@ -288,7 +293,9 @@ begin
differs — so the label is carried verbatim. Both default to
False/'' for ordinary instance fields. }
EncodeBool(F.IsClassVar) +
EncodeLpstr(F.ClassVarEmitName);
EncodeLpstr(F.ClassVarEmitName) +
{ member visibility ordinal (private/protected/strict) }
EncodeLpstr(IntToStr(Ord(F.Visibility)));
end;
end;
@ -335,6 +342,8 @@ begin
{ static-method flag — distinct from VTableSlot (both static and final
non-virtual instance methods carry slot -1). }
EncodeBool (AR.IsStatic) +
{ member visibility ordinal }
EncodeLpstr(IntToStr(Ord(AR.Visibility))) +
EncodeCount(AR.Params.Count);
for J := 0 to AR.Params.Count - 1 do
begin
@ -386,7 +395,9 @@ begin
EncodeBool(P.IsDefault) +
{ `static property` — accessors take no implicit Self. An importer
needs this to dispatch reads/writes without a receiver. }
EncodeBool(P.IsStatic);
EncodeBool(P.IsStatic) +
{ member visibility ordinal }
EncodeLpstr(IntToStr(Ord(P.Visibility)));
end;
end;
@ -1831,6 +1842,7 @@ var
IsWeak: Boolean;
IsClassVar: Boolean;
ClassVarEmit: string;
Vis: Integer;
F: TFieldDecl;
begin
C := DecodeCount(AText, APos);
@ -1839,15 +1851,18 @@ begin
FldName := ReadLpstrAt(AText, APos);
FldType := ReadLpstrAt(AText, APos);
IsWeak := DecodeBool(AText, APos);
{ Order must mirror EncodeFieldList: IsClassVar then ClassVarEmitName. }
{ Order must mirror EncodeFieldList: IsClassVar then ClassVarEmitName
then the visibility ordinal. }
IsClassVar := DecodeBool(AText, APos);
ClassVarEmit := ReadLpstrAt(AText, APos);
Vis := StrToInt(ReadLpstrAt(AText, APos));
F := TFieldDecl.Create();
F.Names.Add(FldName);
F.TypeName := FldType;
F.IsWeak := IsWeak;
F.IsClassVar := IsClassVar;
F.ClassVarEmitName := ClassVarEmit;
F.Visibility := TMemberVisibility(Vis);
ATarget.Add(F);
end;
end;
@ -1898,8 +1913,10 @@ begin
Result.IsOverride := DecodeBool(AText, APos);
Result.ResolvedQbeName := ReadLpstrAt(AText, APos);
Result.VTableSlot := StrToInt(ReadLpstrAt(AText, APos));
{ Order must mirror EncodeMethodSig: IsStatic follows VTableSlot. }
{ Order must mirror EncodeMethodSig: IsStatic follows VTableSlot, then the
visibility ordinal. }
Result.IsStatic := DecodeBool(AText, APos);
Result.Visibility := TMemberVisibility(StrToInt(ReadLpstrAt(AText, APos)));
Pc := DecodeCount(AText, APos);
for J := 1 to Pc do
begin
@ -2011,8 +2028,10 @@ begin
P.IndexParamName := ReadLpstrAt(AText, APos);
P.IndexTypeName := ReadLpstrAt(AText, APos);
P.IsDefault := DecodeBool(AText, APos);
{ Order must mirror EncodePropertyList: IsStatic follows IsDefault. }
{ Order must mirror EncodePropertyList: IsStatic follows IsDefault, then
the visibility ordinal. }
P.IsStatic := DecodeBool(AText, APos);
P.Visibility := TMemberVisibility(StrToInt(ReadLpstrAt(AText, APos)));
ATarget.Add(P);
end;
end;

1
compiler/src/test/pascal/TestRunner.pas
View file

@ -124,6 +124,7 @@ uses
cp.test.classof,
cp.test.staticmembers,
cp.test.e2e.staticmembers,
cp.test.visibility,
cp.test.publishedrtti,
cp.test.attributes,
cp.test.proctypes_ofobject,

16
compiler/src/test/pascal/cp.test.e2e.threading.pas
View file

@ -110,18 +110,20 @@ const
var I: Integer;
begin
{ Spin until terminated. The loop must exit *only* via the terminate
flag so FTerminated is guaranteed True when read — an early-break
flag so Terminated is guaranteed True when read — an early-break
escape would let the worker finish before the main thread's Terminate
landed, making the printed flag race between 0 and 1. The large cap is
only a safety net so a missed Terminate cannot hang the test forever. }
only a safety net so a missed Terminate cannot hang the test forever.
Read the public Terminated property — the backing FTerminated field is
private to TThread and not visible to subclasses. }
I := 0;
while not Self.FTerminated do
while not Self.Terminated do
begin
I := I + 1;
if I > 2000000000 then
break
end;
WriteLn(Self.FTerminated)
WriteLn(Self.Terminated)
end;
var T: TLoopThread;
begin
@ -147,11 +149,13 @@ const
end;
var T: TQuickThread;
begin
{ Read the public Finished property — the backing FFinished field is
private to TThread and not visible outside the class. }
T := TQuickThread.Create(True);
WriteLn(T.FFinished);
WriteLn(T.Finished);
T.Start();
T.WaitFor();
WriteLn(T.FFinished)
WriteLn(T.Finished)
end.
''';

33
compiler/src/test/pascal/cp.test.staticmembers.pas
View file

@ -574,6 +574,7 @@ type
procedure TestSem_StaticVar_BareReadResolves;
procedure TestSem_StaticVar_NotAnInstanceField;
procedure TestSem_StaticVar_RejectsStringType;
procedure TestSem_StaticVar_AcceptsClassType;
procedure TestSem_StaticMethod_NoSelf_CannotTouchInstanceField;
procedure TestSem_StaticMethod_CanReadStaticVar;
@ -715,6 +716,38 @@ begin
AnalyseExpectErrorMsg(Src, 'static var');
end;
procedure TStaticMembersSemTests.TestSem_StaticVar_AcceptsClassType;
const
Src =
'''
program P;
type
TConfig = class
private static var
FInstance: TConfig;
public
static function Instance: TConfig;
end;
static function TConfig.Instance: TConfig;
begin
if FInstance = nil then FInstance := TConfig.Create();
Result := FInstance;
end;
begin TConfig.Instance(); end.
''';
var
Prog: TProgram;
begin
{ A class-typed (self-referential) static var is the canonical singleton
shape. This used to corrupt the heap during AST/symbol-table teardown
(a double-free of the shared GlobalEmitName string registered on the two
static-var symbols). Drive the full analyse -> Free cycle and assert it
completes without error — the teardown is the part under test. }
Prog := AnalyseSrc(Src);
Prog.Free();
AssertTrue('class-typed static var analyses and tears down cleanly', True);
end;
procedure TStaticMembersSemTests.TestSem_StaticMethod_NoSelf_CannotTouchInstanceField;
const
Src =

11
compiler/src/test/pascal/cp.test.unitinterface.pas
View file

@ -2559,7 +2559,7 @@ begin
try
Parser := TParser.Create(Lex);
try
Result := Parser.ParseProgram();
Result := Parser.Parse(); { public entry; ParseProgram is a private internal }
finally
Parser.Free();
end;
@ -2691,11 +2691,12 @@ begin
Iface := TUnitInterface.Create('U');
try
Buf := WriteUnitInterface(Iface);
{ Blaise Pos is 0-based; match-at-start returns 0. Version is 4 since
TRoutineSig.IsStatic was added to the method-sig encoded layout (on top
of v3's IsClassVar/ClassVarEmitName, property IsStatic, ConstDecls). }
{ Blaise Pos is 0-based; match-at-start returns 0. Version is 5 since
member Visibility (private/protected/strict) was added to the field,
method, and property encoded layouts (on top of v4's TRoutineSig.IsStatic
and v3's static-member facts). }
AssertTrue('starts with magic',
Pos('BLAISE-IFACE 4', Buf) = 0);
Pos('BLAISE-IFACE 5', Buf) = 0);
finally
Iface.Free();
end;

772
compiler/src/test/pascal/cp.test.visibility.pas Normal file
View file

@ -0,0 +1,772 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit cp.test.visibility;
{ Tests for member visibility ENFORCEMENT — private / protected / strict.
Feature 2 of the static/visibility work. Before this, Blaise parsed the
visibility keywords but enforced none of them (private was effectively a
comment) and had no `strict` keyword.
Coverage:
* PARSER (TVisibilityParseTests) — the visibility section keywords, the
`strict` soft keyword before private/protected, and the rejection of
`strict public` / `strict published` / bare `strict`. Asserts the
Visibility flag lands on the field/method/property AST nodes.
* SEMANTIC (TVisibilitySemTests) — qualified member access is rejected when
out of scope and accepted when in scope, for fields, methods, and
properties, across private / protected / strict-private / strict-protected.
Cross-unit private/protected enforcement (the .bif round-trip) is exercised by
the self-hosting warm-cache fixpoint and the standalone cross-unit compile
checks; the in-process harness here covers the within-translation-unit rules
(different type in the same program = "same unit", so private is visible but
strict private is not). }
interface
uses
Classes, SysUtils, blaise.testing,
uLexer, uParser, uAST, uSemantic, uSymbolTable;
type
TVisibilityParseTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function ClassOf(AProg: TProgram; AIndex: Integer): TClassTypeDef;
procedure ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
published
procedure TestParse_PrivateField_SetsMvPrivate;
procedure TestParse_ProtectedField_SetsMvProtected;
procedure TestParse_PublishedField_SetsMvPublished;
procedure TestParse_DefaultIsPublic;
procedure TestParse_StrictPrivateField_SetsMvStrictPrivate;
procedure TestParse_StrictProtectedField_SetsMvStrictProtected;
procedure TestParse_StrictComposesWithStatic;
procedure TestParse_StrictPublic_Rejected;
procedure TestParse_BareStrict_Rejected;
procedure TestParse_StrictAsOrdinaryIdentOutsideClass;
end;
TVisibilitySemTests = class(TTestCase)
private
procedure AnalyseExpectOK(const ASrc: string);
procedure AnalyseExpectReject(const ASrc, AExpectedSubstr: string);
published
{ private — unit-scoped }
procedure TestSem_PrivateField_SameUnitOtherProc_OK;
procedure TestSem_PrivateField_OwnMethod_OK;
procedure TestSem_PrivateMethod_SameUnitOtherType_OK;
{ strict private — type-scoped }
procedure TestSem_StrictPrivateField_CrossType_Rejected;
procedure TestSem_StrictPrivateField_OwnMethod_OK;
procedure TestSem_StrictPrivateMethod_CrossType_Rejected;
{ protected — descendant types (and, being unit-scoped, same-unit code) }
procedure TestSem_ProtectedField_Descendant_OK;
procedure TestSem_ProtectedField_SameUnitUnrelated_OK;
{ strict protected — declaring type + descendants }
procedure TestSem_StrictProtectedField_Descendant_OK;
procedure TestSem_StrictProtectedField_NonDescendant_Rejected;
{ public / published — visible everywhere }
procedure TestSem_PublicField_CrossType_OK;
{ strict composes with static }
procedure TestSem_StrictPrivateStaticVar_OwnMethod_OK;
procedure TestSem_StrictPrivateStaticVar_CrossType_Rejected;
{ property visibility }
procedure TestSem_PrivateProperty_CrossType_OK;
procedure TestSem_StrictPrivateProperty_CrossType_Rejected;
end;
implementation
{ ================================================================== }
{ Parser tests }
{ ================================================================== }
function TVisibilityParseTests.ParseSrc(const ASrc: string): TProgram;
var L: TLexer; P: TParser;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Result := P.Parse();
finally
P.Free(); L.Free();
end;
end;
function TVisibilityParseTests.ClassOf(AProg: TProgram; AIndex: Integer): TClassTypeDef;
var TD: TTypeDecl;
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[AIndex]);
Result := TD.Def as TClassTypeDef;
end;
procedure TVisibilityParseTests.ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
var Prog: TProgram;
begin
try
Prog := ParseSrc(ASrc);
Prog.Free();
Fail('Expected EParseError');
except
on E: EParseError do
AssertTrue('error contains "' + AExpectedSubstr + '" (got: ' + E.Message + ')',
Pos(AExpectedSubstr, E.Message) >= 0);
end;
end;
procedure TVisibilityParseTests.TestParse_PrivateField_SetsMvPrivate;
const
Src =
'''
program P;
type
TFoo = class
private
FX: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
AssertTrue('field is mvPrivate',
TFieldDecl(CD.Fields.Items[0]).Visibility = mvPrivate);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_ProtectedField_SetsMvProtected;
const
Src =
'''
program P;
type
TFoo = class
protected
FX: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
AssertTrue('field is mvProtected',
TFieldDecl(CD.Fields.Items[0]).Visibility = mvProtected);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_PublishedField_SetsMvPublished;
const
Src =
'''
program P;
type
TFoo = class
published
FX: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
AssertTrue('field is mvPublished',
TFieldDecl(CD.Fields.Items[0]).Visibility = mvPublished);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_DefaultIsPublic;
const
Src =
'''
program P;
type
TFoo = class
FX: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
AssertTrue('default field is mvPublic',
TFieldDecl(CD.Fields.Items[0]).Visibility = mvPublic);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_StrictPrivateField_SetsMvStrictPrivate;
const
Src =
'''
program P;
type
TFoo = class
strict private
FX: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
AssertTrue('field is mvStrictPrivate',
TFieldDecl(CD.Fields.Items[0]).Visibility = mvStrictPrivate);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_StrictProtectedField_SetsMvStrictProtected;
const
Src =
'''
program P;
type
TFoo = class
strict protected
FX: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
AssertTrue('field is mvStrictProtected',
TFieldDecl(CD.Fields.Items[0]).Visibility = mvStrictProtected);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_StrictComposesWithStatic;
const
Src =
'''
program P;
type
TFoo = class
strict private static var
FInst: Integer;
end;
begin end.
''';
var Prog: TProgram; CD: TClassTypeDef; F: TFieldDecl;
begin
Prog := ParseSrc(Src);
try
CD := ClassOf(Prog, 0);
F := TFieldDecl(CD.Fields.Items[0]);
AssertTrue('strict private', F.Visibility = mvStrictPrivate);
AssertTrue('also static (class var)', F.IsClassVar);
finally
Prog.Free();
end;
end;
procedure TVisibilityParseTests.TestParse_StrictPublic_Rejected;
const
Src =
'''
program P;
type
TFoo = class
strict public
FX: Integer;
end;
begin end.
''';
begin
ParseExpectErrorMsg(Src, 'strict');
end;
procedure TVisibilityParseTests.TestParse_BareStrict_Rejected;
const
{ `strict` not followed by private/protected — followed by `end` here. The
parser must not silently swallow it; a bare `strict` in a member section is
treated as an ordinary field-start identifier, so this parses `strict` as a
field name and then errors on the missing ':'. Either way it must NOT parse
as a valid empty class. }
Src =
'''
program P;
type
TFoo = class
strict public
end;
begin end.
''';
begin
ParseExpectErrorMsg(Src, 'strict');
end;
procedure TVisibilityParseTests.TestParse_StrictAsOrdinaryIdentOutsideClass;
const
{ `strict` is a SOFT keyword — outside a class/record body it must remain a
usable identifier (here a local variable name). }
Src =
'''
program P;
var
strict: Integer;
begin
strict := 1;
end.
''';
var Prog: TProgram;
begin
Prog := ParseSrc(Src);
AssertTrue('strict usable as ordinary identifier outside a class', Prog <> nil);
Prog.Free();
end;
{ ================================================================== }
{ Semantic enforcement tests }
{ ================================================================== }
procedure TVisibilitySemTests.AnalyseExpectOK(const ASrc: string);
var L: TLexer; P: TParser; A: TSemanticAnalyser; Prog: TProgram;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Prog := P.Parse();
finally
P.Free(); L.Free();
end;
A := TSemanticAnalyser.Create();
try
A.Analyse(Prog);
finally
A.Free();
end;
Prog.Free();
end;
procedure TVisibilitySemTests.AnalyseExpectReject(const ASrc, AExpectedSubstr: string);
var L: TLexer; P: TParser; A: TSemanticAnalyser; Prog: TProgram;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Prog := P.Parse();
finally
P.Free(); L.Free();
end;
A := TSemanticAnalyser.Create();
try
try
A.Analyse(Prog);
Fail('Expected ESemanticError for out-of-scope access');
except
on E: ESemanticError do
AssertTrue('error contains "' + AExpectedSubstr + '" (got: ' + E.Message + ')',
Pos(AExpectedSubstr, E.Message) >= 0);
end;
finally
A.Free();
Prog.Free();
end;
end;
procedure TVisibilitySemTests.TestSem_PrivateField_SameUnitOtherProc_OK;
const
Src =
'''
program P;
type
TB = class
private
FSecret: Integer;
end;
procedure Touch(b: TB);
begin
b.FSecret := 1;
end;
var b: TB;
begin
b := TB.Create();
Touch(b);
end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_PrivateField_OwnMethod_OK;
const
Src =
'''
program P;
type
TB = class
private
FSecret: Integer;
public
procedure Bump;
end;
procedure TB.Bump;
begin
Self.FSecret := Self.FSecret + 1;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_PrivateMethod_SameUnitOtherType_OK;
const
Src =
'''
program P;
type
TM = class
private
procedure Hidden;
end;
TUser = class
public
procedure Use(m: TM);
end;
procedure TM.Hidden; begin end;
procedure TUser.Use(m: TM);
begin
m.Hidden();
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictPrivateField_CrossType_Rejected;
const
Src =
'''
program P;
type
TC = class
strict private
FX: Integer;
end;
TD = class
public
procedure Poke(c: TC);
end;
procedure TD.Poke(c: TC);
begin
c.FX := 1;
end;
begin end.
''';
begin
AnalyseExpectReject(Src, 'not accessible');
end;
procedure TVisibilitySemTests.TestSem_StrictPrivateField_OwnMethod_OK;
const
Src =
'''
program P;
type
TC = class
strict private
FX: Integer;
public
procedure Bump;
end;
procedure TC.Bump;
begin
Self.FX := Self.FX + 1;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictPrivateMethod_CrossType_Rejected;
const
Src =
'''
program P;
type
TM = class
strict private
procedure Hidden;
end;
TUser = class
public
procedure Use(m: TM);
end;
procedure TM.Hidden; begin end;
procedure TUser.Use(m: TM);
begin
m.Hidden();
end;
begin end.
''';
begin
AnalyseExpectReject(Src, 'not accessible');
end;
procedure TVisibilitySemTests.TestSem_ProtectedField_Descendant_OK;
const
Src =
'''
program P;
type
TBase = class
protected
FProt: Integer;
end;
TDeriv = class(TBase)
public
procedure Use;
end;
procedure TDeriv.Use;
begin
Self.FProt := 9;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_ProtectedField_SameUnitUnrelated_OK;
const
{ protected is private (unit-scoped) PLUS descendants — so an UNRELATED type
in the SAME unit can still reach it. The cross-unit unrelated REJECT case
requires a separate compilation unit and is covered by the standalone
cross-unit compile checks + the warm-cache fixpoint. }
Src =
'''
program P;
type
TBase = class
protected
FProt: Integer;
end;
TOther = class
public
procedure Poke(b: TBase);
end;
procedure TOther.Poke(b: TBase);
begin
b.FProt := 1;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictProtectedField_Descendant_OK;
const
Src =
'''
program P;
type
TE = class
strict protected
FY: Integer;
end;
TSub = class(TE)
public
procedure Use;
end;
procedure TSub.Use;
begin
Self.FY := 1;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictProtectedField_NonDescendant_Rejected;
const
Src =
'''
program P;
type
TE = class
strict protected
FY: Integer;
end;
TOther = class
public
procedure Poke(e: TE);
end;
procedure TOther.Poke(e: TE);
begin
e.FY := 1;
end;
begin end.
''';
begin
AnalyseExpectReject(Src, 'not accessible');
end;
procedure TVisibilitySemTests.TestSem_PublicField_CrossType_OK;
const
Src =
'''
program P;
type
TF = class
public
FOpen: Integer;
end;
TUser = class
public
procedure Poke(f: TF);
end;
procedure TUser.Poke(f: TF);
begin
f.FOpen := 1;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictPrivateStaticVar_OwnMethod_OK;
const
Src =
'''
program P;
type
TS = class
strict private static var
FInst: Integer;
public
static procedure Init;
end;
static procedure TS.Init;
begin
FInst := 0;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictPrivateStaticVar_CrossType_Rejected;
const
Src =
'''
program P;
type
TS = class
strict private static var
FInst: Integer;
end;
TOther = class
public
procedure Poke;
end;
procedure TOther.Poke;
begin
TS.FInst := 1;
end;
begin end.
''';
begin
{ A strict-private static var is reachable only from TS's own methods; a
qualified TS.FInst from another type must be rejected. }
AnalyseExpectReject(Src, 'not accessible');
end;
procedure TVisibilitySemTests.TestSem_PrivateProperty_CrossType_OK;
const
{ private (unit-scoped) — another type in the SAME program can read it. }
Src =
'''
program P;
type
TG = class
private
FVal: Integer;
private
property Val: Integer read FVal write FVal;
end;
TUser = class
public
function Read(g: TG): Integer;
end;
function TUser.Read(g: TG): Integer;
begin
Result := g.Val;
end;
begin end.
''';
begin
AnalyseExpectOK(Src);
end;
procedure TVisibilitySemTests.TestSem_StrictPrivateProperty_CrossType_Rejected;
const
Src =
'''
program P;
type
TG = class
strict private
FVal: Integer;
property Val: Integer read FVal write FVal;
end;
TUser = class
public
function Read(g: TG): Integer;
end;
function TUser.Read(g: TG): Integer;
begin
Result := g.Val;
end;
begin end.
''';
begin
AnalyseExpectReject(Src, 'not accessible');
end;
initialization
RegisterTest(TVisibilityParseTests);
RegisterTest(TVisibilitySemTests);
end.

16
docs/grammar.ebnf
View file

@ -303,7 +303,8 @@ ClassDef
* member that follows until the next such keyword. *)
VisibilitySection
= ( PRIVATE | PROTECTED | PUBLIC | PUBLISHED ) [ STATIC ]
= [ STRICT ] ( PRIVATE | PROTECTED ) [ STATIC ]
| ( PUBLIC | PUBLISHED ) [ STATIC ]
| STATIC (* STATIC alone keeps current visibility *)
;
@ -317,9 +318,16 @@ VisibilitySection
* static constants. There is no `class var` / `class function` /
* `class property` — the word `class` is never a member qualifier in Blaise.
*
* Visibility keywords (PRIVATE/PROTECTED/PUBLIC/PUBLISHED) and STATIC are
* contextual: outside a class/record body they remain usable as identifiers,
* except those already reserved elsewhere. *)
* Visibility keywords (PRIVATE/PROTECTED/PUBLIC/PUBLISHED), STRICT and STATIC
* are contextual: outside a class/record body they remain usable as
* identifiers, except those already reserved elsewhere. STRICT is only a
* keyword immediately before PRIVATE or PROTECTED at the start of a member
* section; `strict public`, `strict published` and a bare `strict` are
* errors. Visibility is ENFORCED: PRIVATE is visible only within the
* declaring unit; PROTECTED additionally within descendant types; STRICT
* PRIVATE only within the declaring type's own methods; STRICT PROTECTED
* within the declaring type and its descendants; PUBLIC/PUBLISHED everywhere.
* Visibility composes orthogonally with STATIC. *)
GenericName
= IDENT [ LESS TypeArgList GREATER ] (* plain name or generic specialisation *)

2
tools/bif-coverage/bif-coverage.status
View file

@ -71,6 +71,7 @@ TFieldAccessExpr.IsArrayAccess safe
TFieldAccessExpr.IsClassVarRead safe
TFieldAccessExpr.ClassVarEmitName safe
TFieldAccessExpr.IsStaticPropGet safe
TFieldAccessExpr.BackingFieldRedirect safe
# TIsExpr (uAST.pas:154)
TIsExpr.Obj serialise
@ -291,6 +292,7 @@ TRoutineSig.ResolvedQbeName serialise
TRoutineSig.IsVirtual serialise
TRoutineSig.IsOverride serialise
TRoutineSig.IsStatic serialise
TRoutineSig.Visibility serialise
# TConstEntry (uUnitInterface.pas:102)
TConstEntry.Decl serialise