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

test(bif-coverage): extend drift guard to .bif interface types

Browse source 
bif-coverage verified that every AST node field round-trips through the .bif
encoder/decoder, but the .bif interface-container types (TRoutineSig,
TUnitInterface, TMethodParam, TConstEntry, TVarEntry) were hand-serialised in
WriteMeta/EncodeMethodSig/etc. with no drift guard. Every cached-rebuild bug
just fixed was a serialised field on one of those types dropped from one side
of the round-trip — invisible to the tool, surfacing only as a runtime
miscompile.

Generalise the class scanner to ScanClassFile(path, names, objs, allowList);
add ScanInterfaceTypes() over an allow-list of the container types in
uUnitInterface.pas. Split uUnitInterfaceIO.pas into encoder-side and
decoder-side text and assert each serialised interface-type field's identifier
appears in both — the same looseness as the AST mechanism. Status file gains
the interface-type entries (serialise/safe); mutator-repopulated owning
collections are { no-bif }-exempt (their element data round-trips through the
per-entry encoders).

Negative test confirmed: dropping ImplUsedUnits/HasInitialization/VTableSlot
from either side is now reported as a gap with exit 1. Clean tree exits 0.
This commit is contained in:
Graeme Geldenhuys 2026-06-22 12:34:07 +01:00
parent 2f6ee4588a
commit 74da3eadcc
3 changed files with 311 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -198,13 +198,20 @@ type
emit a call to <Unit>_init at program
startup, or the init section never runs. }
Types: TObjectList; { owned TTypeEntry }
Consts: TObjectList; { owned TConstEntry }
Vars: TObjectList; { owned TVarEntry }
Routines: TObjectList; { owned TRoutineSig — free routines }
{ The owning-collection containers below are populated on decode via
the Add* mutators, not by name; their element data round-trips
through the per-entry encoders/decoders (TTypeEntry, TConstEntry,
TVarEntry, TRoutineSig). The bif-coverage tool checks fields by name
against the encoder/decoder text, so these are marked no-bif: the
named field is not directly serialised, only its contents (which the
entry-type checks already cover). }
Types: TObjectList; { owned TTypeEntry, no-bif }
Consts: TObjectList; { owned TConstEntry, no-bif }
Vars: TObjectList; { owned TVarEntry, no-bif }
Routines: TObjectList; { owned TRoutineSig free routines, no-bif }
InlineBodies: TObjectList; { owned TInlineBody }
GenericBodies: TObjectList; { owned TGenericBody }
InlineBodies: TObjectList; { owned TInlineBody, no-bif }
GenericBodies: TObjectList; { owned TGenericBody, no-bif }
{ ACaseSensitive controls all Find* lookups. Default False
matches Object Pascal semantics; set True for cases that need

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

@ -162,7 +162,7 @@ TTryExceptStmt.ExceptBody serialise
TRaiseStmt.Expr serialise
# TExitStmt (uAST.pas:353)
TExitStmt.Value safe
TExitStmt.Value serialise
TExitStmt.ResultAssign safe
# TBreakStmt (uAST.pas:361)
@ -250,7 +250,7 @@ TMethodCallStmt.IsProcFieldCall safe
TInheritedCallStmt.Name serialise
TInheritedCallStmt.Args serialise
# TMethodCallExpr (uAST.pas:829)
# TMethodCallExpr (uAST.pas:835)
TMethodCallExpr.ObjectName serialise
TMethodCallExpr.Name serialise
TMethodCallExpr.Args serialise
@ -263,3 +263,50 @@ TMethodCallExpr.IsBuiltinToString safe
TMethodCallExpr.IsBuiltinInheritsFrom safe
TMethodCallExpr.IsProcFieldCall safe
# === Interface-container types (uUnitInterface.pas + TMethodParam) ===
# serialise must appear in the encoder AND decoder of uUnitInterfaceIO.pas
# TRoutineSig (uUnitInterface.pas:64)
TRoutineSig.Name serialise
TRoutineSig.IsFunction serialise
TRoutineSig.Params serialise
TRoutineSig.ReturnType serialise
TRoutineSig.IsInline safe
TRoutineSig.IsPublished safe
TRoutineSig.IsExternal safe
TRoutineSig.ExternalName safe
TRoutineSig.CallingConv serialise
TRoutineSig.VTableSlot serialise
TRoutineSig.ResolvedQbeName serialise
TRoutineSig.IsVirtual serialise
TRoutineSig.IsOverride serialise
# TConstEntry (uUnitInterface.pas:97)
TConstEntry.Decl serialise
TConstEntry.TypeRef serialise
# TVarEntry (uUnitInterface.pas:105)
TVarEntry.Name serialise
TVarEntry.TypeRef serialise
TVarEntry.IsThreadVar serialise
# TUnitInterface (uUnitInterface.pas:169)
TUnitInterface.Name serialise
TUnitInterface.SourceFile serialise
TUnitInterface.SourceHash serialise
TUnitInterface.SourceModTime serialise
TUnitInterface.CompilerId serialise
TUnitInterface.UsedUnits serialise
TUnitInterface.ImplUsedUnits serialise
TUnitInterface.HasInitialization serialise
# TMethodParam (uAST.pas:764)
TMethodParam.ParamName serialise
TMethodParam.TypeName serialise
TMethodParam.IsVarParam serialise
TMethodParam.IsConstParam serialise
TMethodParam.IsOutParam serialise
TMethodParam.IsOpenArray serialise
TMethodParam.DefaultValue serialise
TMethodParam.HasDefault serialise

269
tools/bif-coverage/src/main/pascal/BifCoverage.pas
View file

@ -10,6 +10,18 @@
uUnitInterfaceIO.pas, AND that every public field on each such class
is referenced from both sides.
It ALSO covers the .bif interface-container types in
uUnitInterface.pas (TUnitInterface, TRoutineSig, TConstEntry,
TVarEntry) plus TMethodParam (uAST.pas). Their fields are
hand-serialised across WriteMeta / EncodeMethodSig / WriteRoutines /
… rather than via the per-node AST dispatch, so they are checked
against the encoder-side and decoder-side text of uUnitInterfaceIO.pas
as two haystacks: a field counts as covered when its `.Field`
identifier appears in both. Catches the class of bug where a field on
one of those types is dropped from one side of the META / routine
serialiser (e.g. ResolvedQbeName, VTableSlot, ImplUsedUnits,
HasInitialization, a TMethodParam default-value flag).
Catches the two failure modes from docs/extending-ast.adoc:
1. New node class added but never wired into Encode/Read dispatch.
2. New public field added but forgotten from one side of the
@ -17,7 +29,8 @@
fixpoint failure with a length-prefix corruption message.
Field exemption: trailing "no-bif" marker on the field's source line
suppresses the warning. Use for fields populated by semantic only.
suppresses the warning. Use for fields populated by semantic only, or
container fields rebuilt via Add* mutators on decode.
Exit codes: 0 = clean, 1 = coverage gap(s), 2 = I/O error.
*)
@ -25,23 +38,41 @@
program BifCoverage;
uses
SysUtils, Classes, Contnrs, uStrCompat;
SysUtils, Classes, Contnrs, strutils, uStrCompat;
const
AST_REL = 'compiler/src/main/pascal/uAST.pas';
IO_REL = 'compiler/src/main/pascal/uUnitInterfaceIO.pas';
IFACE_REL = 'compiler/src/main/pascal/uUnitInterface.pas';
COMPILER_ID_REL = 'compiler/src/main/pascal/uCompilerId.pas';
ROOT_REL = 'project.xml';
STATUS_REL = 'tools/bif-coverage/bif-coverage.status';
COMPILER_ID_PREFIX = 'blaise-';
{ The .bif interface-container types in uUnitInterface.pas whose
serialised fields are cross-checked against the hand-written
encoder/decoder in uUnitInterfaceIO.pas. These carry the META,
routine and type-entry data that the AST-dispatch mechanism does
NOT see. TInlineBody / TGenericBody / TUnitInterface's private
index fields are intentionally excluded: index lists are rebuilt
from the serialised data on read, and the inline/generic bodies
round-trip as AST blocks already covered by the AST mechanism.
TMethodParam lives in uAST.pas (it is a TASTNode) but is NOT a
TASTStmt/TASTExpr, so the AST mechanism skips it; its fields are
hand-serialised via EncodeMethodSig / EncodeParamFlags /
WriteRoutines, so it is checked here against the IO haystacks. }
IFACE_TYPE_COUNT = 4;
var
GRoot: string;
GAstFile: string;
GIoFile: string;
GIfaceFile: string;
GCompilerIdFile: string;
GRootProject: string;
GStatusFile: string;
GIfaceTypes: array[0 .. IFACE_TYPE_COUNT - 1] of string;
(* Walk up from CWD looking for a directory that contains both
`compiler/src/main/pascal/uAST.pas` and `project.xml`. Lets the
@ -72,6 +103,8 @@ type
Parent: string;
Fields: TStringList;
LineNo: Integer;
SrcName: string; { basename of the source file the class came from,
for [new]/header location reporting }
constructor Create;
destructor Destroy; override;
end;
@ -92,6 +125,14 @@ var
GDecodeObjs: TObjectList;
GErrors: Integer;
{ Interface-container types from uUnitInterface.pas (parallel lists),
plus the encoder-side and decoder-side text of uUnitInterfaceIO.pas
used as two haystacks for the loose `.Field` substring check. }
GIfaceNames: TStringList;
GIfaceObjs: TObjectList; { TASTClass instances (reused for fields) }
GIoEncodeText: string;
GIoDecodeText: string;
constructor TASTClass.Create;
begin
inherited Create;
@ -367,20 +408,37 @@ begin
Exit(True);
end;
procedure ScanAST();
(* True when AAllow is nil (accept every class) or AName appears in
the allow-list. Lets the same scan run over uAST.pas (all classes)
and uUnitInterface.pas (only the target .bif container types). *)
function ClassAccepted(AAllow: TStringList; const AName: string): Boolean;
begin
Result := (AAllow = nil) or (AAllow.IndexOf(AName) >= 0);
end;
(* Generic `T = class ... public ... end;` scanner. Records every
accepted class header and its public field names (with source line
numbers) into ANames / AObjs. The `no-bif` trailing-marker
exemption and the StripLine/ParseClassHeader/ParseFieldNames helpers
are shared with the AST scan. When AAllow is non-nil only classes
named in it are recorded. *)
procedure ScanClassFile(const APath: string;
ANames: TStringList; AObjs: TObjectList; AAllow: TStringList);
var
Lines: TStringList;
InBlockComment, InPublic, InClassBody, HasBody, IsEnd: Boolean;
InBlockComment, InPublic, InClassBody, HasBody, IsEnd, Recording: Boolean;
I, J: Integer;
Raw, Stripped, Trimmed, Name, Parent: string;
Raw, Stripped, Trimmed, Name, Parent, SrcName: string;
Cls: TASTClass;
FieldNames: TStringList;
begin
Lines := LoadLines(GAstFile);
SrcName := ExtractFileName(APath);
Lines := LoadLines(APath);
try
InBlockComment := False;
InClassBody := False;
InPublic := True;
Recording := False;
Cls := nil;
for I := 0 to Lines.Count - 1 do
begin
@ -393,12 +451,19 @@ begin
begin
if ParseClassHeader(Trimmed, Name, Parent, HasBody) then
begin
Cls := TASTClass.Create;
Cls.Name := Name;
Cls.Parent := Parent;
Cls.LineNo := I + 1;
GASTNames.Add(Name);
GASTObjs.Add(Cls);
Recording := ClassAccepted(AAllow, Name);
if Recording then
begin
Cls := TASTClass.Create;
Cls.Name := Name;
Cls.Parent := Parent;
Cls.LineNo := I + 1;
Cls.SrcName := SrcName;
ANames.Add(Name);
AObjs.Add(Cls);
end
else
Cls := nil;
if HasBody then
begin
InClassBody := True;
@ -417,8 +482,14 @@ begin
end;
Continue;
end;
if not Recording then Continue;
if not InPublic then Continue;
if Pos('no-bif', Raw) >= 0 then Continue;
{ A `Name: Type` candidate that carries a parenthesis is a
continuation line of a multi-line method/constructor signature
(e.g. a wrapped 'ACaseSensitive: Boolean = False);' param), not
a real field — skip it. Plain public fields never contain (). }
if (Pos('(', Trimmed) >= 0) or (Pos(')', Trimmed) >= 0) then Continue;
FieldNames := ParseFieldNames(Trimmed);
try
for J := 0 to FieldNames.Count - 1 do
@ -433,6 +504,49 @@ begin
end;
end;
procedure ScanAST();
begin
ScanClassFile(GAstFile, GASTNames, GASTObjs, nil);
end;
(* Scan the .bif container types whose fields are hand-serialised in
uUnitInterfaceIO.pas: the GIfaceTypes from uUnitInterface.pas, plus
TMethodParam from uAST.pas (an AST node the TASTStmt/TASTExpr
dispatch deliberately skips). All land in GIfaceNames / GIfaceObjs
and are checked against the file-level IO haystacks. *)
procedure ScanInterfaceTypes();
var
Allow: TStringList;
I: Integer;
begin
Allow := TStringList.Create;
try
for I := 0 to IFACE_TYPE_COUNT - 1 do
Allow.Add(GIfaceTypes[I]);
ScanClassFile(GIfaceFile, GIfaceNames, GIfaceObjs, Allow);
Allow.Clear;
Allow.Add('TMethodParam');
ScanClassFile(GAstFile, GIfaceNames, GIfaceObjs, Allow);
finally
Allow.Free;
end;
end;
function IfaceAt(I: Integer): TASTClass;
begin
Result := TASTClass(GIfaceObjs.Get(I));
end;
function FindIfaceClass(const AName: string): TASTClass;
var
Idx: Integer;
begin
Idx := GIfaceNames.IndexOf(AName);
if Idx < 0 then Result := nil
else Result := IfaceAt(Idx);
end;
(* Find the body of `function FName(...)` in a list of stripped source
lines and return it as one concatenated string. The body spans from
the first `begin` after the signature to the matching `end;` (depth
@ -612,21 +726,59 @@ begin
end;
end;
(* True when ALine begins (after leading whitespace) a decoder-side
function/procedure - i.e. the boundary between the encoder half and
the decoder half of uUnitInterfaceIO.pas's implementation. The
decoder helpers all sort after every Encode*/Write* routine in
source order, so the first such line splits the file cleanly. *)
function IsDecoderBoundary(const ALine: string): Boolean;
var
P: Integer;
Kw, Nm: string;
begin
Result := False;
P := 0;
Kw := ReadIdent(ALine, P);
if (not SameText(Kw, 'function')) and (not SameText(Kw, 'procedure')) then
Exit;
Nm := ReadIdent(ALine, P);
if (Pos('Read', Nm) = 0) or (Pos('Decode', Nm) = 0) or
(Pos('Split', Nm) = 0) or SameText(Nm, 'LoadEnumMembers') or
SameText(Nm, 'SkipWhitespace') or SameText(Nm, 'IsWhitespaceOrd') or
SameText(Nm, 'IsUpperOrd') or SameText(Nm, 'IsDigitOrd') then
Result := True;
end;
procedure ScanIO();
var
Raw, Cleaned: TStringList;
I: Integer;
InBlockComment: Boolean;
Body, Line: string;
InBlockComment, InImpl, InDecoder: Boolean;
Body, Line, Trimmed: string;
EncSB, DecSB: TStringBuilder;
begin
Raw := LoadLines(GIoFile);
Cleaned := TStringList.Create;
EncSB := TStringBuilder.Create;
DecSB := TStringBuilder.Create;
try
InBlockComment := False;
InImpl := False;
InDecoder := False;
for I := 0 to Raw.Count - 1 do
begin
Line := StripLine(Raw.Strings[I], InBlockComment);
Cleaned.Add(Line);
Trimmed := Trim(Line);
if not InImpl then
begin
if SameText(Trimmed, 'implementation') then InImpl := True;
Continue;
end;
if (not InDecoder) and IsDecoderBoundary(Trimmed) then
InDecoder := True;
if InDecoder then DecSB.AppendLine(Line)
else EncSB.AppendLine(Line);
end;
Body := ExtractFunctionBody(Cleaned, 'EncodeExpr');
CarveEncodeBlocks(Body, GEncodeNames, GEncodeObjs);
@ -636,7 +788,11 @@ begin
CarveDecodeBlocks(Body, GDecodeNames, GDecodeObjs);
Body := ExtractFunctionBody(Cleaned, 'ReadStmt');
CarveDecodeBlocks(Body, GDecodeNames, GDecodeObjs);
GIoEncodeText := EncSB.ToString();
GIoDecodeText := DecSB.ToString();
finally
DecSB.Free;
EncSB.Free;
Cleaned.Free;
Raw.Free;
end;
@ -880,6 +1036,32 @@ begin
end;
Outp.Add('');
end;
{ ----- .bif interface-container types -------------------------
These fields are hand-serialised across WriteMeta/EncodeMethodSig/
WriteRoutines/... rather than via the AST dispatch, so they are
checked against the file-level encoder/decoder haystacks. }
Outp.Add('# === Interface-container types (uUnitInterface.pas + TMethodParam) ===');
Outp.Add('# serialise must appear in the encoder AND decoder of uUnitInterfaceIO.pas');
Outp.Add('');
for I := 0 to GIfaceNames.Count - 1 do
begin
Cls := IfaceAt(I);
Header := '# ' + Cls.Name + ' (' + Cls.SrcName + ':' +
IntToStr(Cls.LineNo) + ')';
Outp.Add(Header);
for J := 0 to Cls.Fields.Count - 1 do
begin
FieldName := Cls.Fields.Strings[J];
if Pos('.' + FieldName, GIoEncodeText) >= 0 then
State := 'serialise'
else
State := 'safe';
Outp.Add(Cls.Name + '.' + FieldName + ' ' + State);
end;
Outp.Add('');
end;
Outp.SaveToFile(GStatusFile);
WriteLn('bif-coverage: wrote ' + GStatusFile);
finally
@ -901,7 +1083,7 @@ var
Cls: TASTClass;
Blk: TIOBlock;
KnownFields: TStringList;
EncoderHasField, DecoderHasField: Boolean;
EncoderHasField, DecoderHasField, IsIface: Boolean;
begin
if not FileExists(GStatusFile) then
begin
@ -934,7 +1116,14 @@ begin
end;
ClsName := Copy(Key, 0, SpacePos);
FieldName := Copy(Key, SpacePos + 1, Length(Key) - SpacePos - 1);
Cls := FindASTClass(ClsName);
{ Probe the iface-container store first: TMethodParam is also an AST
node (so it appears in the AST scan) but has no AST encode/decode
dispatch block — it must be checked against the file-level
haystacks, not the per-class block. }
Cls := FindIfaceClass(ClsName);
IsIface := Cls <> nil;
if Cls = nil then
Cls := FindASTClass(ClsName);
if Cls = nil then
begin
Report(' [stale] status names unknown class ' + Key);
@ -945,10 +1134,20 @@ begin
Report(' [stale] ' + Key + ' is not a public field on ' + ClsName);
Continue;
end;
Blk := FindBlock(GEncodeNames, GEncodeObjs, ClsName);
EncoderHasField := (Blk <> nil) and (Pos('.' + FieldName, Blk.Body) >= 0);
Blk := FindBlock(GDecodeNames, GDecodeObjs, ClsName);
DecoderHasField := (Blk <> nil) and (Pos('.' + FieldName, Blk.Body) >= 0);
if IsIface then
begin
{ Interface-container fields are hand-serialised across many
functions; check the file-level encoder/decoder haystacks. }
EncoderHasField := Pos('.' + FieldName, GIoEncodeText) >= 0;
DecoderHasField := Pos('.' + FieldName, GIoDecodeText) >= 0;
end
else
begin
Blk := FindBlock(GEncodeNames, GEncodeObjs, ClsName);
EncoderHasField := (Blk <> nil) and (Pos('.' + FieldName, Blk.Body) >= 0);
Blk := FindBlock(GDecodeNames, GDecodeObjs, ClsName);
DecoderHasField := (Blk <> nil) and (Pos('.' + FieldName, Blk.Body) >= 0);
end;
if State = 'serialise' then
begin
if not EncoderHasField then
@ -1010,6 +1209,20 @@ begin
Key + Loc);
end;
end;
{ Forward check: every public field of each .bif interface-container
type must be classified in the status file. }
for I := 0 to GIfaceNames.Count - 1 do
begin
Cls := IfaceAt(I);
for J := 0 to Cls.Fields.Count - 1 do
begin
Key := Cls.Name + '.' + Cls.Fields.Strings[J];
Loc := ' (' + Cls.SrcName + ':' + IntToStr(FieldLineNo(Cls, J)) + ')';
if KnownFields.IndexOf(Key) < 0 then
Report(' [new] not in status (mark as serialise or safe) ' +
Key + Loc);
end;
end;
finally
Status.Free;
KnownFields.Free;
@ -1021,9 +1234,11 @@ begin
GASTObjs.Free; { owns: frees TASTClass instances }
GEncodeObjs.Free; { owns: frees TIOBlock instances }
GDecodeObjs.Free;
GIfaceObjs.Free; { owns: frees TASTClass instances }
GASTNames.Free;
GEncodeNames.Free;
GDecodeNames.Free;
GIfaceNames.Free;
end;
begin
@ -1038,17 +1253,25 @@ begin
end;
GAstFile := GRoot + AST_REL;
GIoFile := GRoot + IO_REL;
GIfaceFile := GRoot + IFACE_REL;
GCompilerIdFile := GRoot + COMPILER_ID_REL;
GRootProject := GRoot + ROOT_REL;
GStatusFile := GRoot + STATUS_REL;
GIfaceTypes[0] := 'TUnitInterface';
GIfaceTypes[1] := 'TRoutineSig';
GIfaceTypes[2] := 'TConstEntry';
GIfaceTypes[3] := 'TVarEntry';
GASTNames := TStringList.Create;
GASTObjs := TObjectList.Create(True);
GEncodeNames := TStringList.Create;
GEncodeObjs := TObjectList.Create(True);
GDecodeNames := TStringList.Create;
GDecodeObjs := TObjectList.Create(True);
GIfaceNames := TStringList.Create;
GIfaceObjs := TObjectList.Create(True);
GEncodeNames.Duplicates := dupAccept;
GDecodeNames.Duplicates := dupAccept;
GIfaceNames.Duplicates := dupAccept;
if not FileExists(GAstFile) then
begin
WriteLn('bif-coverage: cannot open ' + GAstFile);
@ -1059,7 +1282,13 @@ begin
WriteLn('bif-coverage: cannot open ' + GIoFile);
Halt(2);
end;
if not FileExists(GIfaceFile) then
begin
WriteLn('bif-coverage: cannot open ' + GIfaceFile);
Halt(2);
end;
ScanAST();
ScanInterfaceTypes();
ScanIO();
WriteLn('bif-coverage: scanned ' + IntToStr(GASTNames.Count) +
' AST classes, ' + IntToStr(GEncodeNames.Count) +