5894411a35
Adopts the Swift/LLVM model: Apache License 2.0 with the Runtime Library Exception text used verbatim by the Swift project. SPDX identifier: Apache-2.0 WITH Swift-exception. Apache 2.0 brings an explicit patent grant and patent-retaliation clause that BSD-3 lacks. The Runtime Library Exception ensures binaries produced by the Blaise compiler do not inherit attribution obligations from the linked-in RTL. * LICENSE — full Apache 2.0 + RLE text (replaces the deleted LICENCE). * NOTICE — project header plus QBE attribution (MIT, vendored). * docs/language-rationale.adoc — new Project Governance section capturing the decision, alternatives considered, and rationale. * SPDX headers updated across all .pas, .pp, .inc, .c source files, build scripts, PasBuild plugins, and the Makefile. * project.xml license field updated. * tools/migrate_full.py HEADER template updated so generated self-hosting source carries the new licence.
434 lines
16 KiB
ObjectPascal
434 lines
16 KiB
ObjectPascal
{
|
||
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.staticarray;
|
||
|
||
{$mode objfpc}{$H+}
|
||
|
||
{ Tests for static array declarations and element access:
|
||
parsing, semantic analysis, and QBE IR code generation. }
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, fpcunit, testregistry,
|
||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||
|
||
type
|
||
TStaticArrayTests = class(TTestCase)
|
||
private
|
||
function ParseSrc(const ASrc: string): TProgram;
|
||
function AnalyseSrc(const ASrc: string): TProgram;
|
||
function GenIR(const ASrc: string): string;
|
||
published
|
||
{ ------------------------------------------------------------------ }
|
||
{ Parser }
|
||
{ ------------------------------------------------------------------ }
|
||
procedure TestParse_StaticArray_TypeName;
|
||
procedure TestParse_StaticArray_SubscriptAssign_Name;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Semantic }
|
||
{ ------------------------------------------------------------------ }
|
||
procedure TestSemantic_StaticArray_Kind;
|
||
procedure TestSemantic_StaticArray_ElementType;
|
||
procedure TestSemantic_StaticArray_Bounds;
|
||
procedure TestSemantic_StaticArray_ByteSize;
|
||
procedure TestSemantic_StaticArray_IntArray;
|
||
procedure TestSemantic_StaticArray_NonZero_LowBound;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Codegen }
|
||
{ ------------------------------------------------------------------ }
|
||
procedure TestCodegen_StaticArray_AllocEmitted;
|
||
procedure TestCodegen_StaticArray_MemsetEmitted;
|
||
procedure TestCodegen_StaticArray_WriteEmitted;
|
||
procedure TestCodegen_StaticArray_ReadEmitted;
|
||
procedure TestCodegen_StaticArray_NonZero_OffsetSubtracted;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Low / High }
|
||
{ ------------------------------------------------------------------ }
|
||
procedure TestSemantic_StaticArray_Low_ReturnsInteger;
|
||
procedure TestSemantic_StaticArray_High_ReturnsInteger;
|
||
procedure TestCodegen_StaticArray_Low_EmitsLowBound;
|
||
procedure TestCodegen_StaticArray_High_EmitsHighBound;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Address-of }
|
||
{ ------------------------------------------------------------------ }
|
||
procedure TestParse_AddrOf_NodeType;
|
||
procedure TestSemantic_AddrOf_ReturnsPointerType;
|
||
procedure TestSemantic_AddrOf_BaseTypeIsByte;
|
||
procedure TestCodegen_AddrOf_NoLoad;
|
||
procedure TestCodegen_AddrOf_AddressArithmetic;
|
||
end;
|
||
|
||
implementation
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Helpers }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
function TStaticArrayTests.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 TStaticArrayTests.AnalyseSrc(const ASrc: string): TProgram;
|
||
var A: TSemanticAnalyser;
|
||
begin
|
||
Result := ParseSrc(ASrc);
|
||
A := TSemanticAnalyser.Create;
|
||
try
|
||
A.Analyse(Result);
|
||
finally
|
||
A.Free;
|
||
end;
|
||
end;
|
||
|
||
function TStaticArrayTests.GenIR(const ASrc: string): string;
|
||
var P: TProgram; CG: TCodeGenQBE;
|
||
begin
|
||
P := AnalyseSrc(ASrc);
|
||
try
|
||
CG := TCodeGenQBE.Create;
|
||
try
|
||
CG.Generate(P);
|
||
Result := CG.GetOutput;
|
||
finally
|
||
CG.Free;
|
||
end;
|
||
finally
|
||
P.Free;
|
||
end;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Shared source snippets }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
const
|
||
SrcByteBuf =
|
||
'program SA;' + LineEnding +
|
||
'procedure Foo;' + LineEnding +
|
||
'var Buf: array[0..7] of Byte;' + LineEnding +
|
||
'begin' + LineEnding +
|
||
' Buf[0] := 42' + LineEnding +
|
||
'end;' + LineEnding +
|
||
'begin end.';
|
||
|
||
SrcIntArray =
|
||
'program SA;' + LineEnding +
|
||
'procedure Foo;' + LineEnding +
|
||
'var A: array[0..3] of Integer;' + LineEnding +
|
||
'begin' + LineEnding +
|
||
' A[2] := 99' + LineEnding +
|
||
'end;' + LineEnding +
|
||
'begin end.';
|
||
|
||
SrcReadBack =
|
||
'program SA;' + LineEnding +
|
||
'function GetFirst: Integer;' + LineEnding +
|
||
'var A: array[0..3] of Integer;' + LineEnding +
|
||
'begin' + LineEnding +
|
||
' A[0] := 7;' + LineEnding +
|
||
' Result := A[0]' + LineEnding +
|
||
'end;' + LineEnding +
|
||
'begin end.';
|
||
|
||
SrcNonZero =
|
||
'program SA;' + LineEnding +
|
||
'procedure Foo;' + LineEnding +
|
||
'var R: array[5..9] of Integer;' + LineEnding +
|
||
'begin' + LineEnding +
|
||
' R[5] := 1' + LineEnding +
|
||
'end;' + LineEnding +
|
||
'begin end.';
|
||
|
||
SrcAddrOf =
|
||
'program SA;' + LineEnding +
|
||
'procedure Foo;' + LineEnding +
|
||
'var Buf: array[0..7] of Byte;' + LineEnding +
|
||
' P: ^Byte;' + LineEnding +
|
||
'begin' + LineEnding +
|
||
' P := @Buf[0]' + LineEnding +
|
||
'end;' + LineEnding +
|
||
'begin end.';
|
||
|
||
SrcLowHigh =
|
||
'program SA;' + LineEnding +
|
||
'function Len: Integer;' + LineEnding +
|
||
'var A: array[3..7] of Integer;' + LineEnding +
|
||
'begin' + LineEnding +
|
||
' Result := High(A) - Low(A) + 1' + LineEnding +
|
||
'end;' + LineEnding +
|
||
'begin end.';
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Parser tests }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
procedure TStaticArrayTests.TestParse_StaticArray_TypeName;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl;
|
||
begin
|
||
P := ParseSrc(SrcByteBuf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
AssertEquals('type name encoded', 'array[0..7] of Byte', Decl.TypeName);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestParse_StaticArray_SubscriptAssign_Name;
|
||
var P: TProgram; MD: TMethodDecl; Stmt: TStaticSubscriptAssign;
|
||
begin
|
||
P := ParseSrc(SrcByteBuf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
AssertTrue('stmt is TStaticSubscriptAssign',
|
||
MD.Body.Stmts[0] is TStaticSubscriptAssign);
|
||
Stmt := TStaticSubscriptAssign(MD.Body.Stmts[0]);
|
||
AssertEquals('array name', 'Buf', Stmt.ArrayName);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Semantic tests }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_Kind;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl;
|
||
begin
|
||
P := AnalyseSrc(SrcByteBuf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
AssertNotNull('ResolvedType set', Decl.ResolvedType);
|
||
AssertEquals('kind is tyStaticArray',
|
||
Ord(tyStaticArray), Ord(Decl.ResolvedType.Kind));
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_ElementType;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl; SAT: TStaticArrayTypeDesc;
|
||
begin
|
||
P := AnalyseSrc(SrcByteBuf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
AssertTrue('is TStaticArrayTypeDesc', Decl.ResolvedType is TStaticArrayTypeDesc);
|
||
SAT := TStaticArrayTypeDesc(Decl.ResolvedType);
|
||
AssertNotNull('ElementType set', SAT.ElementType);
|
||
AssertEquals('element is tyByte', Ord(tyByte), Ord(SAT.ElementType.Kind));
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_Bounds;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl; SAT: TStaticArrayTypeDesc;
|
||
begin
|
||
P := AnalyseSrc(SrcByteBuf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
SAT := TStaticArrayTypeDesc(Decl.ResolvedType);
|
||
AssertEquals('LowBound = 0', 0, SAT.LowBound);
|
||
AssertEquals('HighBound = 7', 7, SAT.HighBound);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_ByteSize;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl;
|
||
begin
|
||
P := AnalyseSrc(SrcByteBuf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
{ 8 elements × 1 byte each = 8 bytes }
|
||
AssertEquals('ByteSize = 8', 8, Decl.ResolvedType.ByteSize);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_IntArray;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl;
|
||
begin
|
||
P := AnalyseSrc(SrcIntArray);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
{ 4 elements × 4 bytes each = 16 bytes }
|
||
AssertEquals('ByteSize = 16', 16, Decl.ResolvedType.ByteSize);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_NonZero_LowBound;
|
||
var P: TProgram; MD: TMethodDecl; Decl: TVarDecl; SAT: TStaticArrayTypeDesc;
|
||
begin
|
||
P := AnalyseSrc(SrcNonZero);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Decl := TVarDecl(MD.Body.Decls[0]);
|
||
SAT := TStaticArrayTypeDesc(Decl.ResolvedType);
|
||
AssertEquals('LowBound = 5', 5, SAT.LowBound);
|
||
AssertEquals('HighBound = 9', 9, SAT.HighBound);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Codegen tests }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_AllocEmitted;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcByteBuf);
|
||
{ 8-byte Byte array: alloc4 alignment, 8 bytes total }
|
||
AssertTrue('alloc4 8 emitted', Pos('alloc4 8', IR) > 0);
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_MemsetEmitted;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcByteBuf);
|
||
AssertTrue('memset call emitted', Pos('call $memset', IR) > 0);
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_WriteEmitted;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcByteBuf);
|
||
{ Byte element write uses storeb }
|
||
AssertTrue('storeb emitted', Pos('storeb', IR) > 0);
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_ReadEmitted;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcReadBack);
|
||
{ Integer element read uses loadw }
|
||
AssertTrue('loadw emitted', Pos('loadw', IR) > 0);
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_NonZero_OffsetSubtracted;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcNonZero);
|
||
{ R[5] with LowBound=5: offset = (5-5)*4 = 0; sub instruction emitted }
|
||
AssertTrue('sub for low-bound adjustment', Pos('=l sub', IR) > 0);
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Low / High tests }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_Low_ReturnsInteger;
|
||
var P: TProgram;
|
||
begin
|
||
{ If Low(A) on a static array fails semantic analysis an exception is raised here }
|
||
P := AnalyseSrc(SrcLowHigh);
|
||
try
|
||
AssertNotNull('program analysed', P);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_StaticArray_High_ReturnsInteger;
|
||
var P: TProgram;
|
||
begin
|
||
{ If High(A) on a static array fails semantic analysis an exception is raised here }
|
||
P := AnalyseSrc(SrcLowHigh);
|
||
try
|
||
AssertNotNull('program analysed', P);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_Low_EmitsLowBound;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcLowHigh);
|
||
{ Low(A) on array[3..7] emits: copy 3 }
|
||
AssertTrue('copy 3 for Low(A)', Pos('copy 3', IR) > 0);
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_StaticArray_High_EmitsHighBound;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcLowHigh);
|
||
{ High(A) on array[3..7] emits: copy 7 }
|
||
AssertTrue('copy 7 for High(A)', Pos('copy 7', IR) > 0);
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Address-of tests }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
procedure TStaticArrayTests.TestParse_AddrOf_NodeType;
|
||
var P: TProgram; MD: TMethodDecl; Assign: TAssignment;
|
||
begin
|
||
P := ParseSrc(SrcAddrOf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Assign := TAssignment(MD.Body.Stmts[0]);
|
||
AssertTrue('expr is TAddrOfExpr', Assign.Expr is TAddrOfExpr);
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_AddrOf_ReturnsPointerType;
|
||
var P: TProgram; MD: TMethodDecl; Assign: TAssignment;
|
||
begin
|
||
P := AnalyseSrc(SrcAddrOf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Assign := TAssignment(MD.Body.Stmts[0]);
|
||
AssertNotNull('expr resolved', Assign.Expr.ResolvedType);
|
||
AssertEquals('@Buf[0] resolves to tyPointer',
|
||
Ord(tyPointer), Ord(Assign.Expr.ResolvedType.Kind));
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestSemantic_AddrOf_BaseTypeIsByte;
|
||
var P: TProgram; MD: TMethodDecl; Assign: TAssignment; PT: TPointerTypeDesc;
|
||
begin
|
||
P := AnalyseSrc(SrcAddrOf);
|
||
try
|
||
MD := TMethodDecl(P.Block.ProcDecls[0]);
|
||
Assign := TAssignment(MD.Body.Stmts[0]);
|
||
AssertTrue('is TPointerTypeDesc', Assign.Expr.ResolvedType is TPointerTypeDesc);
|
||
PT := TPointerTypeDesc(Assign.Expr.ResolvedType);
|
||
AssertNotNull('BaseType set', PT.BaseType);
|
||
AssertEquals('BaseType is tyByte', Ord(tyByte), Ord(PT.BaseType.Kind));
|
||
finally P.Free; end;
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_AddrOf_NoLoad;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcAddrOf);
|
||
{ @Buf[0] takes address only — no loadub should appear }
|
||
AssertTrue('no loadub emitted', Pos('loadub', IR) = 0);
|
||
end;
|
||
|
||
procedure TStaticArrayTests.TestCodegen_AddrOf_AddressArithmetic;
|
||
var IR: string;
|
||
begin
|
||
IR := GenIR(SrcAddrOf);
|
||
{ address is computed: base + offset using add }
|
||
AssertTrue('=l add emitted', Pos('=l add', IR) > 0);
|
||
end;
|
||
|
||
initialization
|
||
RegisterTest(TStaticArrayTests);
|
||
|
||
end.
|