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

fix: record elements in arrays — subscript-LHS chains, deep copy, element reads

Browse source 
Dynamic arrays of records were broken in three interlocking ways:

- Parser: a[i].Field := v (and a[i].Method, chained a[i].F.G := v) on
  the statement LHS raised "Expected ':=' but got '.'" — the subscript
  statement branch only accepted ':=' directly after ']'.  It now
  builds a subscript-rooted postfix chain ending in a TFieldAssignment
  (via ObjExpr) or TMethodCallStmt (via ObjExpr).  grammar.ebnf gains
  SubscriptFieldAssign / SubscriptMethodCall rules.

- Both backends: a[i] := r stored the ADDRESS of r into the element
  instead of copying the record, and element reads loaded the first
  8 bytes of the element as if it were a pointer.  The two bugs masked
  each other (elements aliased r — the TElfSection workaround comment
  in uElfObject.pas documents the symptom).  Record-element subscript
  reads now yield the element address (dyn/open/static arrays) and
  writes do an ARC-aware fieldwise copy: EmitRecordCopy on QBE,
  retain-src/release-dest/memcpy on native.  Native static arrays of
  records had the same read/write bug and are fixed too.

- QBE backend: Exit inside the SECOND (or later) try block of a
  function skipped _PopExcFrame, leaving a stale g_exc_top that
  corrupted later raises/pops.  EmitTryFinallyStmt/EmitTryExceptStmt
  emitted normal and exception paths sequentially but decremented the
  codegen-time FExcDepth on both (net -1 per try statement).  Ported
  the native backend's rebalancing (restore depth before emitting the
  exception path).  This is the likely root cause of the historical
  'avoid bare Exit inside try' convention.

Tests: 3 IR tests (cp.test.dynarray), 4 e2e tests on both backends
(cp.test.e2e.records), IR pop-count + e2e regression for the exc-frame
bug (cp.test.exceptions, cp.test.e2e.exceptions).  Suite: 2912 OK on
working and fixpoint binaries; FIXPOINT_OK; NATIVE_FIXPOINT_OK.
This commit is contained in:
Graeme Geldenhuys 2026-06-11 08:38:08 +01:00
parent 939f03eb0e
commit 7b4db4d11d
8 changed files with 552 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

@ -4981,8 +4981,11 @@ begin
[TOpenArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType.RawSize()]));
Self.Emit(#9'popq %rcx');
Self.Emit(#9'addq %rcx, %rax');
Self.EmitLoadVar('(%rax)',
TOpenArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType);
{ Record elements evaluate to their address — records are by-value via
pointer; loading 8 bytes here would read the first field instead. }
if TOpenArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType.Kind <> tyRecord then
Self.EmitLoadVar('(%rax)',
TOpenArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType);
Exit;
end;
@ -5000,8 +5003,11 @@ begin
[TDynArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType.RawSize()]));
Self.Emit(#9'popq %rcx');
Self.Emit(#9'addq %rcx, %rax');
Self.EmitLoadVar('(%rax)',
TDynArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType);
{ Record elements evaluate to their address — records are by-value via
pointer; loading 8 bytes here would read the first field instead. }
if TDynArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType.Kind <> tyRecord then
Self.EmitLoadVar('(%rax)',
TDynArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType);
Exit;
end;
@ -5022,8 +5028,11 @@ begin
[TStaticArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType.RawSize()]));
Self.Emit(#9'popq %rcx');
Self.Emit(#9'addq %rcx, %rax');
Self.EmitLoadVar('(%rax)',
TStaticArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType);
{ Record elements evaluate to their address — records are by-value via
pointer; loading 8 bytes here would read the first field instead. }
if TStaticArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType.Kind <> tyRecord then
Self.EmitLoadVar('(%rax)',
TStaticArrayTypeDesc(SAE.StrExpr.ResolvedType).ElementType);
Exit;
end;
@ -9260,6 +9269,29 @@ begin
Self.Emit(Format(#9'movq %s(%%rip), %%rcx', [SSA.ArrayName]));
Self.Emit(#9'addq %rcx, %rax');
Self.Emit(#9'movq %rax, %rcx');
if DAElemType.Kind = tyRecord then
begin
{ Record element: ARC-aware copy of the record contents (retain the
source's managed fields, release the destination's, then memcpy).
The source record address was pushed above; %rcx holds the element
address. Push count stays even so calls remain 16-byte aligned. }
Self.Emit(#9'pushq %rbx');
Self.Emit(#9'pushq %r15');
Self.Emit(#9'subq $8, %rsp');
Self.Emit(#9'movq %rcx, %r15'); { dest element addr }
Self.Emit(#9'movq 24(%rsp), %rbx'); { src record addr }
Self.EmitRecordFieldRetains(TRecordTypeDesc(DAElemType), '%rbx');
Self.EmitRecordFieldReleases(TRecordTypeDesc(DAElemType), '%r15');
Self.Emit(#9'movq %r15, %rdi');
Self.Emit(#9'movq %rbx, %rsi');
Self.Emit(Format(#9'movq $%d, %%rdx', [DAElemType.RawSize()]));
Self.Emit(#9'callq memcpy');
Self.Emit(#9'addq $8, %rsp');
Self.Emit(#9'popq %r15');
Self.Emit(#9'popq %rbx');
Self.Emit(#9'addq $8, %rsp'); { drop saved src addr }
Exit;
end;
if DAElemType.Kind = tyString then
begin
Self.Emit(#9'pushq %rcx');
@ -9303,6 +9335,27 @@ begin
Self.Emit(Format(#9'leaq %s(%%rip), %%rcx', [SSA.ArrayName]));
Self.Emit(#9'addq %rcx, %rax');
Self.Emit(#9'movq %rax, %rcx');
if DAElemType.Kind = tyRecord then
begin
{ Record element: ARC-aware copy — same scheme as the dyn-array
record branch above. }
Self.Emit(#9'pushq %rbx');
Self.Emit(#9'pushq %r15');
Self.Emit(#9'subq $8, %rsp');
Self.Emit(#9'movq %rcx, %r15'); { dest element addr }
Self.Emit(#9'movq 24(%rsp), %rbx'); { src record addr }
Self.EmitRecordFieldRetains(TRecordTypeDesc(DAElemType), '%rbx');
Self.EmitRecordFieldReleases(TRecordTypeDesc(DAElemType), '%r15');
Self.Emit(#9'movq %r15, %rdi');
Self.Emit(#9'movq %rbx, %rsi');
Self.Emit(Format(#9'movq $%d, %%rdx', [DAElemType.RawSize()]));
Self.Emit(#9'callq memcpy');
Self.Emit(#9'addq $8, %rsp');
Self.Emit(#9'popq %r15');
Self.Emit(#9'popq %rbx');
Self.Emit(#9'addq $8, %rsp'); { drop saved src addr }
Exit;
end;
if DAElemType.Kind = tyString then
begin
Self.Emit(#9'pushq %rcx');

46
compiler/src/main/pascal/blaise.codegen.qbe.pas
View file

@ -2290,12 +2290,22 @@ begin
{ Exception path: capture exception, pop frame, run finally body, re-raise.
ARC cleanup is NOT emitted here — the outer handler (or function exit)
is responsible for releasing variables that are still in scope. Releasing
them here would nil variables that the outer except handler still reads. }
them here would nil variables that the outer except handler still reads.
Restore codegen-time FExcDepth/FFinallyStack to the try-entry level first:
both paths are emitted sequentially but are runtime alternatives, so each
must balance the bookkeeping independently. Without this the second and
later try blocks in a function are emitted with FExcDepth one too low and
a non-local exit inside them skips the frame pop (stale g_exc_top → crash
on the next raise). }
Inc(FExcDepth);
FFinallyStack.Add(AStmt.FinallyBody);
EmitLine('@' + LblFinExc);
ExcTemp := AllocTemp();
EmitLine(Format(' %s =l call $_CurrentException()', [ExcTemp]));
EmitLine(' call $_PopExcFrame()');
Dec(FExcDepth);
FFinallyStack.Delete(FFinallyStack.Count - 1);
for I := 0 to AStmt.FinallyBody.Stmts.Count - 1 do
EmitStmt(TASTStmt(AStmt.FinallyBody.Stmts.Items[I]));
EmitLine(Format(' call $_Reraise(l %s)', [ExcTemp]));
@ -2347,7 +2357,12 @@ begin
FFinallyStack.Delete(FFinallyStack.Count - 1);
EmitLine(Format(' jmp @%s', [LblEnd]));
{ Exception path: capture exception before popping frame, then pop }
{ Exception path: capture exception before popping frame, then pop.
Restore codegen-time FExcDepth/FFinallyStack to the try-entry level first:
both paths are emitted sequentially but are runtime alternatives, so each
must balance the bookkeeping independently (see EmitTryFinallyStmt). }
Inc(FExcDepth);
FFinallyStack.Add(nil);
EmitLine('@' + LblExcept);
if AStmt.Handlers.Count > 0 then
@ -2358,6 +2373,7 @@ begin
EmitLine(Format(' %s =l call $_CurrentException()', [ExcTemp]));
EmitLine(' call $_PopExcFrame()');
Dec(FExcDepth);
FFinallyStack.Delete(FFinallyStack.Count - 1);
for I := 0 to AStmt.Handlers.Count - 1 do
begin
@ -2408,6 +2424,7 @@ begin
{ Plain catch-all body }
EmitLine(' call $_PopExcFrame()');
Dec(FExcDepth);
FFinallyStack.Delete(FFinallyStack.Count - 1);
for I := 0 to AStmt.ExceptBody.Stmts.Count - 1 do
EmitStmt(TASTStmt(AStmt.ExceptBody.Stmts.Items[I]));
EmitLine(Format(' jmp @%s', [LblEnd]));
@ -12345,10 +12362,15 @@ begin
IdxL := AllocTemp();
Offset := AllocTemp();
ElemPtr := AllocTemp();
ByteVal := AllocTemp();
EmitLine(Format(' %s =l extsw %s', [IdxL, IdxW]));
EmitLine(Format(' %s =l mul %s, %d', [Offset, IdxL, ElemSize]));
EmitLine(Format(' %s =l add %s, %s', [ElemPtr, StrPtr, Offset]));
{ Record elements: return address directly — records are by-value via pointer }
if ElemType.ElementType.Kind = tyRecord then
begin
Exit(ElemPtr);
end;
ByteVal := AllocTemp();
EmitLine(Format(' %s =%s %s %s', [ByteVal, QType, QLoad, ElemPtr]));
Exit(ByteVal);
end;
@ -12364,10 +12386,15 @@ begin
IdxL := AllocTemp();
Offset := AllocTemp();
ElemPtr := AllocTemp();
ByteVal := AllocTemp();
EmitLine(Format(' %s =l extsw %s', [IdxL, IdxW]));
EmitLine(Format(' %s =l mul %s, %d', [Offset, IdxL, ElemSize]));
EmitLine(Format(' %s =l add %s, %s', [ElemPtr, StrPtr, Offset]));
{ Record elements: return address directly — records are by-value via pointer }
if TDynArrayTypeDesc(AExpr.StrExpr.ResolvedType).ElementType.Kind = tyRecord then
begin
Exit(ElemPtr);
end;
ByteVal := AllocTemp();
EmitLine(Format(' %s =%s %s %s', [ByteVal, QType, QLoad, ElemPtr]));
Exit(ByteVal);
end;
@ -12636,6 +12663,17 @@ begin
IdxL := AllocTemp();
Offset := AllocTemp();
ElemPtr := AllocTemp();
{ Record elements: copy the record contents into the element slot
(ARC-aware fieldwise copy), never a single 8-byte store. }
if ElemType.Kind = tyRecord then
begin
EmitLine(Format(' %s =l extsw %s', [IdxL, IdxW]));
EmitLine(Format(' %s =l mul %s, %d', [Offset, IdxL, ElemSize]));
EmitLine(Format(' %s =l add %s, %s', [ElemPtr, PCharBase, Offset]));
ElemVal := EmitExpr(AStmt.ValueExpr);
EmitRecordCopy(TRecordTypeDesc(ElemType), ElemPtr, ElemVal);
Exit;
end;
if ElemType.Kind in [tyByte, tyBoolean] then
ElemVal := EmitByteRhs(AStmt.ValueExpr)
else

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

@ -1894,6 +1894,8 @@ var
CastRcv: TASTExpr;
FCallNode: TFuncCallExpr;
SubAssign: TStaticSubscriptAssign;
SubNode: TStringSubscriptExpr;
ChainBase: TASTExpr;
ExitS: TExitStmt;
begin
Result := nil;
@ -1994,7 +1996,12 @@ begin
if Check(tkLBracket) then
begin
{ Static array subscript assignment: Name[IndexExpr] := ValueExpr }
{ Subscript on the statement LHS. Three shapes:
Name[I] := V — element write (TStaticSubscriptAssign)
Name[I]....F := V — field assignment through the element
(TFieldAssignment via ObjExpr)
Name[I]....M / ....M(args) — method call on the element
(TMethodCallStmt via ObjExpr) }
Advance(); { consume '[' }
SubAssign := TStaticSubscriptAssign.Create();
SubAssign.Line := Line;
@ -2003,13 +2010,116 @@ begin
try
SubAssign.IndexExpr := ParseExpr();
Expect(tkRBracket);
Expect(tkAssign);
SubAssign.ValueExpr := ParseExpr();
if Check(tkAssign) then
begin
Advance(); { consume ':=' }
SubAssign.ValueExpr := ParseExpr();
Exit(SubAssign);
end;
except
SubAssign.Free();
raise;
end;
Exit(SubAssign);
{ Postfix chain on the element: rebuild Name[Index] as an expression
base, then consume '.' field / '[' subscript suffixes until the
terminating assignment or method call. }
PtrIdNode := TIdentExpr.Create();
PtrIdNode.Line := Line;
PtrIdNode.Col := Col;
PtrIdNode.Name := Name;
SubNode := TStringSubscriptExpr.Create();
SubNode.Line := Line;
SubNode.Col := Col;
SubNode.StrExpr := PtrIdNode;
SubNode.IndexExpr := SubAssign.IndexExpr;
SubAssign.IndexExpr := nil; { ownership transferred to SubNode }
SubAssign.Free();
SubAssign := nil;
ChainBase := SubNode;
try
repeat
if Check(tkLBracket) then
begin
{ Further subscript: ChainBase[Index] }
Advance(); { consume '[' }
SubNode := TStringSubscriptExpr.Create();
SubNode.Line := FCurrent.Line;
SubNode.Col := FCurrent.Col;
SubNode.StrExpr := ChainBase;
ChainBase := SubNode;
SubNode.IndexExpr := ParseExpr();
Expect(tkRBracket);
if Check(tkAssign) then
raise EParseError.Create(Format(
'Subscript assignment through a chained base is not yet supported at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
Continue;
end;
if not Check(tkDot) then
raise EParseError.Create(Format(
'Expected ''.'' or '':='' after subscript at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
Advance(); { consume '.' }
if not Check(tkIdent) then
raise EParseError.Create(Format(
'Expected field or method name at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
SecondIdent := FCurrent.Value;
Advance(); { consume ident }
if Check(tkAssign) then
begin
{ Name[I]....F := Expr — field assignment through the element }
Advance(); { consume ':=' }
FldAssign := TFieldAssignment.Create();
FldAssign.Line := Line;
FldAssign.Col := Col;
FldAssign.FieldName := SecondIdent;
FldAssign.ObjExpr := ChainBase;
ChainBase := nil;
FldAssign.Expr := ParseExpr();
Exit(FldAssign);
end;
if Check(tkLParen) then
begin
{ Name[I]....M(args) — method call on the element }
MCall := TMethodCallStmt.Create();
MCall.Line := Line;
MCall.Col := Col;
MCall.ObjectName := '';
MCall.Name := SecondIdent;
MCall.ObjExpr := ChainBase;
ChainBase := nil;
Advance(); { consume '(' }
if not Check(tkRParen) then
ParseMethodCallArgList(MCall);
Expect(tkRParen);
Exit(MCall);
end;
if Check(tkDot) or Check(tkLBracket) then
begin
{ Extend the chain: Name[I].F.… or Name[I].F[J]… }
FldNode := TFieldAccessExpr.Create();
FldNode.Line := Line;
FldNode.Col := Col;
FldNode.Base := ChainBase;
FldNode.FieldName := SecondIdent;
ChainBase := FldNode;
Continue;
end;
{ Statement boundary: parenless method call Name[I]....M }
MCall := TMethodCallStmt.Create();
MCall.Line := Line;
MCall.Col := Col;
MCall.ObjectName := '';
MCall.Name := SecondIdent;
MCall.ObjExpr := ChainBase;
ChainBase := nil;
Exit(MCall);
until False;
except
ChainBase.Free();
raise;
end;
end;
if Check(tkCaret) then

74
compiler/src/test/pascal/cp.test.dynarray.pas
View file

@ -61,6 +61,13 @@ type
procedure TestCodegen_DynArray_AddrOfRecordFieldElement;
procedure TestSemantic_DynArray_High_Accepted;
procedure TestSemantic_DynArray_Low_Accepted;
{ ------------------------------------------------------------------ }
{ Record elements: a[i] := r copies; a[i].F := v assigns in place }
{ ------------------------------------------------------------------ }
procedure TestParse_DynArray_RecordElem_FieldAssign_Accepted;
procedure TestCodegen_DynArray_RecordElem_Write_FieldwiseCopy;
procedure TestCodegen_DynArray_RecordElem_FieldAssign_StringARC;
end;
implementation
@ -477,6 +484,73 @@ begin
Self.CountOccurrences(IR, 'add') > 0);
end;
procedure TDynArrayTests.TestParse_DynArray_RecordElem_FieldAssign_Accepted;
var Prog: TProgram;
begin
{ a[i].Field := v on the statement LHS used to raise
"Expected ':=' but got '.'" — the subscript statement branch only
accepted ':=' directly after ']'. }
Prog := ParseSrc('''
program P;
type TRec = record Name: String; Number: Integer; end;
var A: array of TRec;
begin
SetLength(A, 2);
A[0].Name := 'hello';
A[1].Number := 42;
end.
''');
AssertNotNil('program with a[i].Field := v parses', Prog);
Prog.Free();
end;
procedure TDynArrayTests.TestCodegen_DynArray_RecordElem_Write_FieldwiseCopy;
var IR: string;
begin
{ a[i] := r with a record element must copy the record contents
(ARC-aware fieldwise copy), not store the address of r into the
element slot. }
IR := GenIR('''
program P;
type TRec = record Name: String; Number: Integer; end;
procedure Foo;
var A: array of TRec;
R: TRec;
begin
SetLength(A, 2);
A[0] := R;
end;
begin
end.
''');
AssertTrue('string field retained during element copy',
Self.CountOccurrences(IR, 'call $_StringAddRef') > 0);
AssertEquals('record address must not be stored into the element',
0, Self.CountOccurrences(IR, 'storel %_var_R,'));
end;
procedure TDynArrayTests.TestCodegen_DynArray_RecordElem_FieldAssign_StringARC;
var IR: string;
begin
{ a[i].Name := s must write through the element address with string ARC
(retain new value, release old element field). }
IR := GenIR('''
program P;
type TRec = record Name: String; Number: Integer; end;
var A: array of TRec;
S: String;
begin
SetLength(A, 1);
S := 'hello';
A[0].Name := S;
end.
''');
AssertTrue('retains the new string value',
Self.CountOccurrences(IR, 'call $_StringAddRef') > 0);
AssertTrue('releases the old element field value',
Self.CountOccurrences(IR, 'call $_StringRelease') > 0);
end;
initialization
RegisterTest(TDynArrayTests);

53
compiler/src/test/pascal/cp.test.e2e.exceptions.pas
View file

@ -50,6 +50,10 @@ type
{ String variable mutated in finally must be visible after re-raise. }
procedure TestRun_FinallyStringMutation_SurvivesReraise;
{ Exit inside the second try block of a function must pop its exc frame;
a later raise must still dispatch correctly (stale-frame regression). }
procedure TestRun_ExitInSecondTry_LaterRaiseStillWorks;
end;
implementation
@ -473,6 +477,55 @@ begin
AssertEquals('string mutations in finally survive re-raise', 'A,F,H,', Trim(Output));
end;
const
SrcExitInSecondTry = '''
program P;
type EBoom = class end;
function F(n: Integer): Integer;
begin
Result := 0;
try
if n = 0 then
begin
Exit(100);
end;
except
end;
try
repeat
if n > 2 then
begin
Exit(n * 10);
end;
n := n + 1;
until False;
except
end;
end;
var x: Integer;
begin
x := F(0);
writeln(x);
x := F(5);
writeln(x);
try
raise EBoom.Create();
except
on E: EBoom do writeln('caught');
end;
writeln('done');
end.
''';
procedure TE2EExceptionTests.TestRun_ExitInSecondTry_LaterRaiseStillWorks;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcExitInSecondTry,
'100' + LE + '50' + LE + 'caught' + LE + 'done' + LE, 0);
end;
initialization
RegisterTest(TE2EExceptionTests);

130
compiler/src/test/pascal/cp.test.e2e.records.pas
View file

@ -41,6 +41,10 @@ type
procedure TestRun_Record_InterfaceField_AssignCallAndCopy;
procedure TestRun_Record_ByValParam_StringField_HeapARC;
procedure TestRun_Record_ByValArg_InlineCallResult_NestedManaged_NoLeak;
procedure TestRun_DynArrayRecordElem_FieldAssignAndRead;
procedure TestRun_DynArrayRecordElem_CopyNoAlias;
procedure TestRun_StaticArrayRecordElem_FieldAssignAndRead;
procedure TestRun_DynArrayClassElem_MethodCallStmt;
end;
implementation
@ -744,6 +748,132 @@ begin
Pos('outer-heap|inner-heap' + LE, Output) >= 0);
end;
const
SrcDynRecElemFieldAssign = '''
program P;
type
TInner = record N: Integer; end;
TRec = record
Name: String;
Number: Integer;
Inner: TInner;
end;
var
r1, r2: TRec;
a: array of TRec;
begin
SetLength(a, 2);
r1.Name := 'First'; r1.Number := 1;
r2.Name := 'Second'; r2.Number := 2;
a[0] := r1;
a[1] := r2;
writeln(a[0].Name);
a[0].Name := 'Patched';
a[0].Number := 10;
a[0].Inner.N := 7;
writeln(a[0].Name);
writeln(a[1].Name);
writeln(a[0].Number);
writeln(a[1].Number);
writeln(a[0].Inner.N);
writeln(r1.Name);
end.
''';
SrcDynRecElemCopyNoAlias = '''
program P;
type TRec = record Name: String; Number: Integer; end;
var
r: TRec;
a: array of TRec;
begin
SetLength(a, 1);
r.Name := 'one';
r.Number := 1;
a[0] := r;
r.Name := 'two';
r.Number := 2;
writeln(a[0].Name);
writeln(a[0].Number);
r := a[0];
a[0].Name := 'three';
writeln(r.Name);
writeln(r.Number);
writeln(a[0].Name);
end.
''';
SrcStaticRecElemFieldAssign = '''
program P;
type TRec = record Name: String; Number: Integer; end;
var
r1, r2: TRec;
sa: array[0..1] of TRec;
begin
r1.Name := 'First'; r1.Number := 1;
r2.Name := 'Second'; r2.Number := 2;
sa[0] := r1;
sa[1] := r2;
sa[0].Name := 'Patched';
sa[0].Number := 10;
writeln(sa[0].Name);
writeln(sa[1].Name);
writeln(sa[0].Number);
writeln(sa[1].Number);
writeln(r1.Name);
end.
''';
SrcDynClassElemMethodCall = '''
program P;
type
TC = class
V: Integer;
procedure Bump;
end;
procedure TC.Bump;
begin
V := V + 1;
end;
var
a: array of TC;
begin
SetLength(a, 1);
a[0] := TC.Create();
a[0].Bump;
a[0].Bump();
writeln(a[0].V);
end.
''';
procedure TE2ERecordsTests.TestRun_DynArrayRecordElem_FieldAssignAndRead;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDynRecElemFieldAssign,
'First' + LE + 'Patched' + LE + 'Second' + LE + '10' + LE + '2' + LE +
'7' + LE + 'First' + LE, 0);
end;
procedure TE2ERecordsTests.TestRun_DynArrayRecordElem_CopyNoAlias;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDynRecElemCopyNoAlias,
'one' + LE + '1' + LE + 'one' + LE + '1' + LE + 'three' + LE, 0);
end;
procedure TE2ERecordsTests.TestRun_StaticArrayRecordElem_FieldAssignAndRead;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcStaticRecElemFieldAssign,
'Patched' + LE + 'Second' + LE + '10' + LE + '2' + LE + 'First' + LE, 0);
end;
procedure TE2ERecordsTests.TestRun_DynArrayClassElem_MethodCallStmt;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDynClassElemMethodCall, '2' + LE, 0);
end;
initialization
RegisterTest(TE2ERecordsTests);

54
compiler/src/test/pascal/cp.test.exceptions.pas
View file

@ -97,6 +97,12 @@ type
{ Exit inside try/finally must emit the finally body on the exit path,
not just pop the frame. }
procedure TestCodegen_ExitInTryFinally_RunsFinally;
{ Exit inside the SECOND try block of a function must still pop its
frame: the emitter's FExcDepth bookkeeping is per-path, and the
exception path must rebalance it (regression: a double decrement left
later try blocks at depth 0, so their Exit paths skipped the pop and
left a stale g_exc_top -> crash on a later raise/pop). }
procedure TestCodegen_ExitInSecondTryExcept_PopsFrame;
{ ------------------------------------------------------------------ }
{ Codegen — ARC cleanup on exception paths }
@ -672,6 +678,54 @@ end;
The RTL (blaise_exc.c) fixes the contract at 512 bytes — jmp_buf alone is
200 B on Linux x86_64 / ~312 B on macOS ARM64, plus two pointer fields.
Undersizing silently corrupts the caller's stack when setjmp writes jbuf. }
procedure TExceptionTests.TestCodegen_ExitInSecondTryExcept_PopsFrame;
var
IR: string;
N: Integer;
Idx: Integer;
begin
IR := GenIR('''
program P;
function F(n: Integer): Integer;
begin
Result := 0;
try
if n = 0 then
begin
Exit(100);
end;
except
end;
try
repeat
if n > 2 then
begin
Exit(n * 10);
end;
n := n + 1;
until False;
except
end;
end;
begin
end.
''');
{ Each try/except emits three pops: the Exit path inside the try body,
the normal fall-through path, and the handler path. Two try blocks
with one Exit each = 6 pops. The double-decrement bug dropped the
Exit-path pop of the second block (5 pops). }
N := 0;
Idx := 0;
while True do
begin
Idx := PosEx('call $_PopExcFrame()', IR, Idx);
if Idx < 0 then Break;
Inc(N);
Inc(Idx);
end;
AssertEquals('balanced frame pops across both try blocks', 6, N);
end;
procedure TExceptionTests.TestCodegen_TryExcept_FrameAllocSize;
var IR: string;
begin

26
docs/grammar.ebnf
View file

@ -646,6 +646,8 @@ Stmt
| CompoundStmt
| PointerWriteStmt
| StaticSubscriptAssign
| SubscriptFieldAssign
| SubscriptMethodCall
| FieldAssignment
| MethodCall
| Assignment
@ -657,6 +659,30 @@ StaticSubscriptAssign
= IDENT LBRACKET Expr RBRACKET ASSIGN Expr
;
(* A statement starting with IDENT LBRACKET Expr RBRACKET that is NOT
* directly followed by ASSIGN continues as a postfix chain on the element:
* field accesses and further subscripts, terminated by either a field
* assignment (SubscriptFieldAssign) or a method call on the element
* (SubscriptMethodCall). Examples:
* a[0].Name := 'x'; a[i].Inner.N := 5;
* a[0].Bump; a[i].Items.Add(x);
* A terminating subscript on the LHS of ASSIGN (a[i].Items[j] := v) is
* not yet supported. *)
SubscriptFieldAssign
= IDENT LBRACKET Expr RBRACKET { SubscriptSuffix }
DOT IDENT ASSIGN Expr
;
SubscriptMethodCall
= IDENT LBRACKET Expr RBRACKET { SubscriptSuffix }
DOT IDENT [ LPAREN [ ArgList ] RPAREN ]
;
SubscriptSuffix
= DOT IDENT
| LBRACKET Expr RBRACKET
;
IfStmt
= IF Expr THEN Stmt [ ELSE Stmt ]
;