diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 23fbc2a..4764f53 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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 diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 31d2235..982ac29 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 4f0ef47..44836cb 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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 diff --git a/compiler/src/main/pascal/uSemanticExport.pas b/compiler/src/main/pascal/uSemanticExport.pas index 699d6ae..c8fabc2 100644 --- a/compiler/src/main/pascal/uSemanticExport.pas +++ b/compiler/src/main/pascal/uSemanticExport.pas @@ -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 diff --git a/compiler/src/main/pascal/uSemanticImport.pas b/compiler/src/main/pascal/uSemanticImport.pas index e8df86c..ba4e4f9 100644 --- a/compiler/src/main/pascal/uSemanticImport.pas +++ b/compiler/src/main/pascal/uSemanticImport.pas @@ -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]); diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index 9c079a2..a9d0fe6 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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; diff --git a/compiler/src/main/pascal/uUnitInterface.pas b/compiler/src/main/pascal/uUnitInterface.pas index 57ee4b9..ffa6f79 100644 --- a/compiler/src/main/pascal/uUnitInterface.pas +++ b/compiler/src/main/pascal/uUnitInterface.pas @@ -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; diff --git a/compiler/src/main/pascal/uUnitInterfaceIO.pas b/compiler/src/main/pascal/uUnitInterfaceIO.pas index f7b7009..38a2247 100644 --- a/compiler/src/main/pascal/uUnitInterfaceIO.pas +++ b/compiler/src/main/pascal/uUnitInterfaceIO.pas @@ -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; diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 8ab30d5..fa14786 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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, diff --git a/compiler/src/test/pascal/cp.test.e2e.threading.pas b/compiler/src/test/pascal/cp.test.e2e.threading.pas index 8be9fa5..4e75889 100644 --- a/compiler/src/test/pascal/cp.test.e2e.threading.pas +++ b/compiler/src/test/pascal/cp.test.e2e.threading.pas @@ -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. '''; diff --git a/compiler/src/test/pascal/cp.test.staticmembers.pas b/compiler/src/test/pascal/cp.test.staticmembers.pas index 89922b9..7cfe782 100644 --- a/compiler/src/test/pascal/cp.test.staticmembers.pas +++ b/compiler/src/test/pascal/cp.test.staticmembers.pas @@ -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 = diff --git a/compiler/src/test/pascal/cp.test.unitinterface.pas b/compiler/src/test/pascal/cp.test.unitinterface.pas index e39a537..7798d37 100644 --- a/compiler/src/test/pascal/cp.test.unitinterface.pas +++ b/compiler/src/test/pascal/cp.test.unitinterface.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.visibility.pas b/compiler/src/test/pascal/cp.test.visibility.pas new file mode 100644 index 0000000..89f1868 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.visibility.pas @@ -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. diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index dbb5968..de02951 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -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 *) diff --git a/tools/bif-coverage/bif-coverage.status b/tools/bif-coverage/bif-coverage.status index 89ddcae..30ccb2e 100644 --- a/tools/bif-coverage/bif-coverage.status +++ b/tools/bif-coverage/bif-coverage.status @@ -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