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

Add boolean operators, Exit/Break, multi-arg WriteLn, chained field access, generic constraints

Browse source 
Five language features that surfaced as missing during prior sessions,
plus test coverage. All 685 tests pass (634 previously); the five new
end-to-end tests compile-link-run against the RTL to verify real
behaviour beyond IR shape.

- AND/OR/NOT with standard Pascal precedence; operands must be Boolean.
- Exit jumps to a per-function/main exit label so ARC cleanup still
  runs on early return. Break uses a loop-end label stack; rejected
  outside a loop.
- Write/WriteLn now accept any number of arguments, emitting one printf
  per value plus one trailing newline call for WriteLn.
- TFieldAccessExpr gained an optional Base expression; parser wraps
  each additional .IDENT, semantic recurses to type the chain, codegen
  uses a new EmitInstancePtr helper for nested record/class storage.
- <T: class>, <T: record>, <T: TypeName> constraints on generic types,
  interfaces, and standalone functions; validated at instantiation
  (class-kind, value-type, or subclass/interface-implementor check).

Side effect: EmitVarAllocs now memset(0)s record storage so QBE's SSA
checker accepts reads from zero-initialised record fields. Matches
Pascal's defined default-zero semantics.

New test units split by concern: cp.test.booleanops, cp.test.flowjumps,
cp.test.multiwrite, cp.test.chainedfields, cp.test.genericconstraints
(46 new IR-level tests in total). cp.test.e2e gains 5 smoke tests
covering the same features through qbe + cc + run.
This commit is contained in:
Graeme Geldenhuys 2026-04-22 23:06:50 +01:00
parent b897f3e08d
commit b38a486a0e
12 changed files with 1791 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -54,13 +54,15 @@ type
TFieldAccessExpr = class(TASTExpr)
public
RecordName: string;
RecordName: string; { used when Base = nil (leaf access) }
FieldName: string;
Base: TASTExpr; { owned — when non-nil, chained access (e.g. A.B.C) }
FieldInfo: TFieldInfo; { set by uSemantic — nil for constructor calls }
IsConstructorCall: Boolean; { set by uSemantic — TypeName.Create }
IsClassAccess: Boolean; { set by uSemantic — pointer deref needed }
PropRead: TPropertyInfo; { non-nil if this is a method-backed property read }
PropOwnerType: string; { class type name for method-backed property calls }
destructor Destroy; override;
end;
TIsExpr = class(TASTExpr)
@ -78,7 +80,8 @@ type
destructor Destroy; override;
end;
TBinaryOp = (boAdd, boSub, boMul, boDiv, boEQ, boNE, boLT, boGT, boLE, boGE);
TBinaryOp = (boAdd, boSub, boMul, boDiv, boEQ, boNE, boLT, boGT, boLE, boGE,
boAnd, boOr);
TBinaryExpr = class(TASTExpr)
public
@ -88,6 +91,12 @@ type
destructor Destroy; override;
end;
TNotExpr = class(TASTExpr)
public
Expr: TASTExpr; { owned — must be Boolean }
destructor Destroy; override;
end;
{ ------------------------------------------------------------------ }
{ Statements }
{ ------------------------------------------------------------------ }
@ -155,6 +164,12 @@ type
destructor Destroy; override;
end;
{ 'exit' statement — returns from the current procedure/function. }
TExitStmt = class(TASTStmt);
{ 'break' statement — exits the innermost loop. }
TBreakStmt = class(TASTStmt);
TFieldAssignment = class(TASTStmt)
public
RecordName: string;
@ -270,6 +285,8 @@ type
IsOverride: Boolean; { declared with 'override' directive }
VTableSlot: Integer; { -1 = static; >=0 = vtable index (set by uSemantic) }
TypeParams: TStringList; { non-nil = generic function template; owns param names }
TypeParamConstraints: TStringList; { parallel to TypeParams; '' = unconstrained,
'class', 'record', or a concrete type name }
OwnerTypeParams: TStringList; { non-nil = generic owner: 'T' in TList<T>.Add }
constructor Create;
destructor Destroy; override;
@ -309,8 +326,9 @@ type
{ Generic type template: type TBox<T> = class ... end }
TGenericTypeDef = class(TASTTypeDef)
public
ParamNames: TStringList; { owned — type parameter names, e.g. ['T'] or ['K','V'] }
ClassDef: TClassTypeDef; { owned — template class body with unresolved param types }
ParamNames: TStringList; { owned — type parameter names, e.g. ['T'] or ['K','V'] }
ParamConstraints: TStringList; { owned — parallel to ParamNames; '' = unconstrained }
ClassDef: TClassTypeDef; { owned — template class body with unresolved param types }
constructor Create;
destructor Destroy; override;
end;
@ -347,8 +365,9 @@ type
{ Generic interface template: type IFoo<T> = interface ... end }
TGenericInterfaceDef = class(TASTTypeDef)
public
ParamNames: TStringList; { owned — type parameter names, e.g. ['T'] }
IntfDef: TInterfaceTypeDef; { owned — template interface body with unresolved param types }
ParamNames: TStringList; { owned — type parameter names, e.g. ['T'] }
ParamConstraints: TStringList; { owned — parallel to ParamNames; '' = unconstrained }
IntfDef: TInterfaceTypeDef; { owned — template interface body with unresolved param types }
constructor Create;
destructor Destroy; override;
end;
@ -425,6 +444,8 @@ begin
boGT: Result := '>';
boLE: Result := '<=';
boGE: Result := '>=';
boAnd: Result := 'and';
boOr: Result := 'or';
else
Result := '?';
end;
@ -504,6 +525,14 @@ begin
inherited Destroy;
end;
{ TFieldAccessExpr }
destructor TFieldAccessExpr.Destroy;
begin
Base.Free;
inherited Destroy;
end;
{ TIsExpr }
destructor TIsExpr.Destroy;
@ -529,6 +558,14 @@ begin
inherited Destroy;
end;
{ TNotExpr }
destructor TNotExpr.Destroy;
begin
Expr.Free;
inherited Destroy;
end;
{ TAssignment }
destructor TAssignment.Destroy;
@ -660,6 +697,7 @@ destructor TMethodDecl.Destroy;
begin
Params.Free;
TypeParams.Free;
TypeParamConstraints.Free;
OwnerTypeParams.Free;
if OwnBody then Body.Free;
inherited Destroy;
@ -718,13 +756,15 @@ end;
constructor TGenericTypeDef.Create;
begin
inherited Create;
ParamNames := TStringList.Create;
ClassDef := TClassTypeDef.Create;
ParamNames := TStringList.Create;
ParamConstraints := TStringList.Create;
ClassDef := TClassTypeDef.Create;
end;
destructor TGenericTypeDef.Destroy;
begin
ClassDef.Free;
ParamConstraints.Free;
ParamNames.Free;
inherited Destroy;
end;
@ -749,13 +789,15 @@ end;
constructor TGenericInterfaceDef.Create;
begin
inherited Create;
ParamNames := TStringList.Create;
IntfDef := TInterfaceTypeDef.Create;
ParamNames := TStringList.Create;
ParamConstraints := TStringList.Create;
IntfDef := TInterfaceTypeDef.Create;
end;
destructor TGenericInterfaceDef.Destroy;
begin
IntfDef.Free;
ParamConstraints.Free;
ParamNames.Free;
inherited Destroy;
end;

258
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -29,6 +29,8 @@ type
FTempCount: Integer;
FLabelCount: Integer;
FCurrentBlock: TBlock; { block currently being emitted; set by EmitBlock }
FBreakLabels: TStringList; { stack of active loop-end labels; top = innermost }
FExitLabel: string; { label to jmp to for 'exit'; '' = main program }
function AllocTemp: string;
function AllocLabel(const APrefix: string): string;
@ -67,6 +69,10 @@ type
function EmitExpr(AExpr: TASTExpr): string;
function EmitIsExpr(AExpr: TIsExpr): string;
function EmitAsExpr(AExpr: TAsExpr): string;
{ Returns a QBE temp holding a pointer to the storage of a record or class
instance referenced by AExpr. Used by chained field access to traverse
base nodes without loading record aggregates as scalars. }
function EmitInstancePtr(AExpr: TASTExpr): string;
function FieldPtr(const ARecordVar: string; AOffset: Integer): string;
function QbeTypeOf(AType: TTypeDesc): string;
function QbeEscapeString(const AStr: string): string;
@ -85,13 +91,15 @@ implementation
constructor TCodeGenQBE.Create;
begin
inherited Create;
FOutput := TStringList.Create;
FStrLits := TStringList.Create;
FTempCount := 0;
FOutput := TStringList.Create;
FStrLits := TStringList.Create;
FBreakLabels := TStringList.Create;
FTempCount := 0;
end;
destructor TCodeGenQBE.Destroy;
begin
FBreakLabels.Free;
FOutput.Free;
FStrLits.Free;
inherited Destroy;
@ -227,6 +235,12 @@ begin
EmitLine(Format(' %%_var_%s =l alloc8 %d', [VarName, RecSize]))
else
EmitLine(Format(' %%_var_%s =l alloc4 %d', [VarName, RecSize]));
{ Zero-initialise record storage: Pascal records default to 0 and
QBE's SSA checker requires every loaded slot to have at least
one prior store. }
if RecSize > 0 then
EmitLine(Format(' call $memset(l %%_var_%s, w 0, l %d)',
[VarName, RecSize]));
end;
tyClass:
@ -290,6 +304,12 @@ begin
EmitVarAllocs(ABlock);
for I := 0 to ABlock.Stmts.Count - 1 do
EmitStmt(TASTStmt(ABlock.Stmts[I]));
{ Fall-through to exit label so 'exit' and normal flow share cleanup. }
if FExitLabel <> '' then
begin
EmitLine(Format(' jmp @%s', [FExitLabel]));
EmitLine('@' + FExitLabel);
end;
EmitStringCleanup(ABlock);
end;
@ -318,6 +338,8 @@ begin
end;
procedure TCodeGenQBE.EmitStmt(AStmt: TASTStmt);
var
DeadLbl: string;
begin
if AStmt is TTryFinallyStmt then
EmitTryFinallyStmt(TTryFinallyStmt(AStmt))
@ -343,6 +365,25 @@ begin
EmitMethodCall(TMethodCallStmt(AStmt))
else if AStmt is TProcCall then
EmitProcCall(TProcCall(AStmt))
else if AStmt is TExitStmt then
begin
if FExitLabel <> '' then
EmitLine(Format(' jmp @%s', [FExitLabel]))
else
EmitLine(' ret 0');
{ QBE basic blocks must follow a terminator with a new labelled block. }
DeadLbl := AllocLabel('after_exit');
EmitLine('@' + DeadLbl);
end
else if AStmt is TBreakStmt then
begin
if FBreakLabels.Count = 0 then
raise ECodeGenError.Create('break outside loop');
EmitLine(Format(' jmp @%s',
[FBreakLabels[FBreakLabels.Count - 1]]));
DeadLbl := AllocLabel('after_break');
EmitLine('@' + DeadLbl);
end
else
raise ECodeGenError.Create('Unknown statement node type');
end;
@ -526,7 +567,12 @@ begin
{ Body block }
EmitLine('@' + LblBody);
EmitStmt(AStmt.Body);
FBreakLabels.Add(LblEnd);
try
EmitStmt(AStmt.Body);
finally
FBreakLabels.Delete(FBreakLabels.Count - 1);
end;
{ Increment or decrement loop variable }
CurT := AllocTemp;
@ -565,7 +611,12 @@ begin
{ Loop body block }
EmitLine('@' + LblBody);
EmitStmt(AStmt.Body);
FBreakLabels.Add(LblEnd);
try
EmitStmt(AStmt.Body);
finally
FBreakLabels.Delete(FBreakLabels.Count - 1);
end;
EmitLine(Format(' jmp @%s', [LblCond]));
{ Continuation block }
@ -671,6 +722,74 @@ begin
end;
end;
function TCodeGenQBE.EmitInstancePtr(AExpr: TASTExpr): string;
var
Id: TIdentExpr;
Fld: TFieldAccessExpr;
Base: string;
Ptr: string;
Loaded: string;
begin
if AExpr is TIdentExpr then
begin
Id := TIdentExpr(AExpr);
if (AExpr.ResolvedType <> nil) and (AExpr.ResolvedType.Kind = tyClass) then
begin
Loaded := AllocTemp;
EmitLine(Format(' %s =l loadl %%_var_%s', [Loaded, Id.Name]));
Result := Loaded;
end
else
Result := Format('%%_var_%s', [Id.Name]); { inline record }
Exit;
end;
if AExpr is TFieldAccessExpr then
begin
Fld := TFieldAccessExpr(AExpr);
if Fld.Base <> nil then
Base := EmitInstancePtr(Fld.Base)
else
begin
{ Leaf: RecordName-based access, same rules as for TIdentExpr. }
if (Fld.ResolvedType = nil) then
raise ECodeGenError.Create('Chained base has no resolved type');
if Fld.IsClassAccess then
begin
Loaded := AllocTemp;
EmitLine(Format(' %s =l loadl %%_var_%s', [Loaded, Fld.RecordName]));
Base := Loaded;
end
else
Base := Format('%%_var_%s', [Fld.RecordName]);
end;
if Fld.FieldInfo = nil then
raise ECodeGenError.Create(
'Chained field access ''' + Fld.FieldName + ''' has no resolved field info');
if Fld.FieldInfo.Offset > 0 then
begin
Ptr := AllocTemp;
EmitLine(Format(' %s =l add %s, %d',
[Ptr, Base, Fld.FieldInfo.Offset]));
end
else
Ptr := Base;
{ If this field is a class pointer, load it to get the heap object pointer.
If it is an inline record, the pointer itself points to the storage. }
if Fld.FieldInfo.TypeDesc.Kind = tyClass then
begin
Loaded := AllocTemp;
EmitLine(Format(' %s =l loadl %s', [Loaded, Ptr]));
Result := Loaded;
end
else
Result := Ptr;
Exit;
end;
raise ECodeGenError.Create('EmitInstancePtr: unsupported base expression');
end;
function TCodeGenQBE.FieldPtr(const ARecordVar: string; AOffset: Integer): string;
var
PtrTemp: string;
@ -855,13 +974,14 @@ end;
procedure TCodeGenQBE.EmitMethodDef(const ATypeName: string;
AMethod: TMethodDecl);
var
Sig: string;
I: Integer;
Par: TMethodParam;
FuncName: string;
IsFunc: Boolean;
RetQType: string;
RetTemp: string;
Sig: string;
I: Integer;
Par: TMethodParam;
FuncName: string;
IsFunc: Boolean;
RetQType: string;
RetTemp: string;
SavedExitLbl: string;
begin
FuncName := '$' + ATypeName + '_' + AMethod.Name;
IsFunc := AMethod.ResolvedReturnType <> nil;
@ -904,7 +1024,13 @@ begin
end;
end;
EmitBlock(AMethod.Body);
SavedExitLbl := FExitLabel;
FExitLabel := AllocLabel('method_exit');
try
EmitBlock(AMethod.Body);
finally
FExitLabel := SavedExitLbl;
end;
if IsFunc then
begin
@ -1139,15 +1265,16 @@ end;
procedure TCodeGenQBE.EmitFuncDef(ADecl: TMethodDecl; AExported: Boolean);
var
Sig: string;
I: Integer;
Par: TMethodParam;
FuncName: string;
IsFunc: Boolean;
RetQType: string;
RetTemp: string;
ValTemp: string;
Prefix: string;
Sig: string;
I: Integer;
Par: TMethodParam;
FuncName: string;
IsFunc: Boolean;
RetQType: string;
RetTemp: string;
ValTemp: string;
Prefix: string;
SavedExitLbl: string;
begin
FuncName := '$' + QBEMangle(ADecl.Name);
IsFunc := ADecl.ResolvedReturnType <> nil;
@ -1227,7 +1354,13 @@ begin
end;
end;
EmitBlock(ADecl.Body);
SavedExitLbl := FExitLabel;
FExitLabel := AllocLabel('func_exit');
try
EmitBlock(ADecl.Body);
finally
FExitLabel := SavedExitLbl;
end;
{ ARC: release string value params on exit }
for I := 0 to ADecl.Params.Count - 1 do
@ -1350,8 +1483,8 @@ var
ArgExpr: TASTExpr;
ArgTemp: string;
CharPtr: string;
FmtLabel: string;
IsString: Boolean;
I: Integer;
begin
if ACall.Args.Count = 0 then
begin
@ -1360,28 +1493,27 @@ begin
Exit;
end;
if ACall.Args.Count > 1 then
raise ECodeGenError.CreateFmt(
'Write/WriteLn takes at most 1 argument (line %d)', [ACall.Line]);
ArgExpr := TASTExpr(ACall.Args[0]);
IsString := (ArgExpr.ResolvedType <> nil) and ArgExpr.ResolvedType.IsString;
ArgTemp := EmitExpr(ArgExpr);
if IsString then
FmtLabel := IfThen(ANewline, '$__fmt_s_nl', '$__fmt_s')
else
FmtLabel := IfThen(ANewline, '$__fmt_d_nl', '$__fmt_d');
if IsString then
{ Emit one printf call per argument. All formatting is plain ("%d" or "%s")
with no trailing newline; a final "\n" is emitted after the last arg when
ANewline is set (i.e. WriteLn rather than Write). }
for I := 0 to ACall.Args.Count - 1 do
begin
{ String pointer is the header pointer; char data starts at ptr+12. }
CharPtr := AllocTemp;
EmitLine(Format(' %s =l add %s, 12', [CharPtr, ArgTemp]));
EmitLine(Format(' call $printf(l %s, ..., l %s)', [FmtLabel, CharPtr]));
end
else
EmitLine(Format(' call $printf(l %s, ..., w %s)', [FmtLabel, ArgTemp]));
ArgExpr := TASTExpr(ACall.Args[I]);
IsString := (ArgExpr.ResolvedType <> nil) and ArgExpr.ResolvedType.IsString;
ArgTemp := EmitExpr(ArgExpr);
if IsString then
begin
{ String pointer is the header pointer; char data starts at ptr+12. }
CharPtr := AllocTemp;
EmitLine(Format(' %s =l add %s, 12', [CharPtr, ArgTemp]));
EmitLine(Format(' call $printf(l $__fmt_s, ..., l %s)', [CharPtr]));
end
else
EmitLine(Format(' call $printf(l $__fmt_d, ..., w %s)', [ArgTemp]));
end;
if ANewline then
EmitLine(' call $printf(l $__fmt_nl)');
end;
function TCodeGenQBE.EmitExpr(AExpr: TASTExpr): string;
@ -1586,6 +1718,30 @@ begin
else if AExpr is TFieldAccessExpr then
begin
FldAccess := TFieldAccessExpr(AExpr);
{ Chained access: compute base storage pointer, then load the field from
(base_ptr + offset) using the field's QBE type. }
if FldAccess.Base <> nil then
begin
L := EmitInstancePtr(FldAccess.Base);
if FldAccess.FieldInfo = nil then
raise ECodeGenError.CreateFmt(
'Chained field ''%s'' has no resolved field info', [FldAccess.FieldName]);
if FldAccess.FieldInfo.Offset > 0 then
begin
Ptr := AllocTemp;
EmitLine(Format(' %s =l add %s, %d',
[Ptr, L, FldAccess.FieldInfo.Offset]));
end
else
Ptr := L;
QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc);
T := AllocTemp;
if QType = 'w' then LoadInstr := 'loadw'
else LoadInstr := 'loadl';
EmitLine(Format(' %s =%s %s %s', [T, QType, LoadInstr, Ptr]));
Result := T;
Exit;
end;
if FldAccess.IsConstructorCall then
begin
{ TypeName.Create — allocate zeroed instance on heap (calloc zeros all fields) }
@ -1743,6 +1899,8 @@ begin
boGT: Op := 'csgtw';
boLE: Op := 'cslew';
boGE: Op := 'csgew';
boAnd: Op := 'and';
boOr: Op := 'or';
else
Op := 'add';
end;
@ -1750,6 +1908,14 @@ begin
end;
Result := T;
end
else if AExpr is TNotExpr then
begin
{ Logical not on Boolean (0/1): xor with 1 flips the low bit. }
L := EmitExpr(TNotExpr(AExpr).Expr);
T := AllocTemp;
EmitLine(Format(' %s =w xor %s, 1', [T, L]));
Result := T;
end
else if AExpr is TDerefExpr then
begin
{ P^ — load the value at the pointer address }
@ -1880,9 +2046,11 @@ begin
try
EmitMethodDefs(AProg);
EmitStandaloneDefs(AProg);
FExitLabel := 'main_exit';
EmitMainHeader;
EmitBlock(AProg.Block);
EmitMainFooter;
FExitLabel := '';
finally
FOutput := SavedOutput;
end;

12
compiler/src/main/pascal/uLexer.pas
View file

@ -55,6 +55,11 @@ type
tkOverride,
tkIs,
tkAs,
tkAnd,
tkOr,
tkNot,
tkExit,
tkBreak,
{ Identifier }
tkIdent,
{ Arithmetic operators }
@ -147,6 +152,11 @@ begin
else if AUpper = 'OVERRIDE' then Result := tkOverride
else if AUpper = 'IS' then Result := tkIs
else if AUpper = 'AS' then Result := tkAs
else if AUpper = 'AND' then Result := tkAnd
else if AUpper = 'OR' then Result := tkOr
else if AUpper = 'NOT' then Result := tkNot
else if AUpper = 'EXIT' then Result := tkExit
else if AUpper = 'BREAK' then Result := tkBreak
else
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
end;
@ -217,6 +227,8 @@ begin
text := FTok.TokenTextUpper;
if text = 'VIRTUAL' then Result.Kind := tkVirtual
else if text = 'OVERRIDE' then Result.Kind := tkOverride
else if text = 'EXIT' then Result.Kind := tkExit
else if text = 'BREAK' then Result.Kind := tkBreak
else Result.Kind := tkIdent;
Result.Value := FTok.TokenText;
end;

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

@ -305,11 +305,13 @@ end;
procedure TParser.ParseTypeDecl(ABlock: TBlock);
var
TD: TTypeDecl;
GD: TGenericTypeDef;
GID: TGenericInterfaceDef;
ParamNames: TStringList;
IsGeneric: Boolean;
TD: TTypeDecl;
GD: TGenericTypeDef;
GID: TGenericInterfaceDef;
ParamNames: TStringList;
ParamConstraints: TStringList;
IsGeneric: Boolean;
Constraint: string;
begin
TD := TTypeDecl.Create;
TD.Line := FCurrent.Line;
@ -325,7 +327,8 @@ begin
if IsGeneric then
begin
Advance; { consume '<' }
ParamNames := TStringList.Create;
ParamNames := TStringList.Create;
ParamConstraints := TStringList.Create;
try
if not Check(tkIdent) then
raise EParseError.CreateFmt(
@ -333,6 +336,20 @@ begin
[FCurrent.Line, FCurrent.Col]);
ParamNames.Add(FCurrent.Value);
Advance;
{ Optional constraint: T : (class | record | TypeName) }
Constraint := '';
if Check(tkColon) then
begin
Advance;
if Check(tkClass) then begin Constraint := 'class'; Advance; end
else if Check(tkRecord) then begin Constraint := 'record'; Advance; end
else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end
else
raise EParseError.CreateFmt(
'Expected ''class'', ''record'', or a type name after '':'' at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
end;
ParamConstraints.Add(Constraint);
while Check(tkComma) do
begin
Advance;
@ -342,6 +359,19 @@ begin
[FCurrent.Line, FCurrent.Col]);
ParamNames.Add(FCurrent.Value);
Advance;
Constraint := '';
if Check(tkColon) then
begin
Advance;
if Check(tkClass) then begin Constraint := 'class'; Advance; end
else if Check(tkRecord) then begin Constraint := 'record'; Advance; end
else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end
else
raise EParseError.CreateFmt(
'Expected ''class'', ''record'', or a type name after '':'' at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
end;
ParamConstraints.Add(Constraint);
end;
Expect(tkGreaterThan);
Expect(tkEquals);
@ -351,6 +381,7 @@ begin
GID.Line := TD.Line;
GID.Col := TD.Col;
GID.ParamNames.AddStrings(ParamNames);
GID.ParamConstraints.AddStrings(ParamConstraints);
GID.IntfDef.Free;
GID.IntfDef := ParseInterfaceDef;
TD.Def := GID;
@ -365,11 +396,13 @@ begin
GD.Line := TD.Line;
GD.Col := TD.Col;
GD.ParamNames.AddStrings(ParamNames);
GD.ParamConstraints.AddStrings(ParamConstraints);
GD.ClassDef.Free;
GD.ClassDef := ParseClassDef;
TD.Def := GD;
end;
finally
ParamConstraints.Free;
ParamNames.Free;
end;
end
@ -509,9 +542,12 @@ end;
function TParser.ParseMethodDecl(IsFunction: Boolean): TMethodDecl;
var
TempParams: TStringList;
TempParams: TStringList;
TempConstraints: TStringList;
Constraint: string;
begin
TempParams := nil;
TempParams := nil;
TempConstraints := nil;
Result := TMethodDecl.Create;
try
Result.Line := FCurrent.Line;
@ -529,9 +565,10 @@ begin
or the generic owner class ('procedure TList<T>.Add'). Parse tentatively;
DOT after '>' decides which case it is. }
if Check(tkLessThan) and (PeekKind = tkIdent) and
(PeekKind2 in [tkGreaterThan, tkComma]) then
(PeekKind2 in [tkGreaterThan, tkComma, tkColon]) then
begin
TempParams := TStringList.Create;
TempParams := TStringList.Create;
TempConstraints := TStringList.Create;
try
Advance; { consume '<' }
if not Check(tkIdent) then
@ -539,6 +576,19 @@ begin
[FCurrent.Line, FCurrent.Col]);
TempParams.Add(FCurrent.Value);
Advance;
Constraint := '';
if Check(tkColon) then
begin
Advance;
if Check(tkClass) then begin Constraint := 'class'; Advance; end
else if Check(tkRecord) then begin Constraint := 'record'; Advance; end
else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end
else
raise EParseError.CreateFmt(
'Expected ''class'', ''record'', or a type name after '':'' at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
end;
TempConstraints.Add(Constraint);
while Check(tkComma) do
begin
Advance;
@ -547,22 +597,40 @@ begin
[FCurrent.Line, FCurrent.Col]);
TempParams.Add(FCurrent.Value);
Advance;
Constraint := '';
if Check(tkColon) then
begin
Advance;
if Check(tkClass) then begin Constraint := 'class'; Advance; end
else if Check(tkRecord) then begin Constraint := 'record'; Advance; end
else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end
else
raise EParseError.CreateFmt(
'Expected ''class'', ''record'', or a type name after '':'' at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
end;
TempConstraints.Add(Constraint);
end;
Expect(tkGreaterThan);
if Check(tkDot) then
begin
{ Generic owner: procedure TList<T>.Add(...) }
{ Generic owner: procedure TList<T>.Add(...) — constraints are
carried on the type decl, not repeated on method impls. }
Result.OwnerTypeParams := TempParams;
TempParams := nil;
FreeAndNil(TempConstraints);
end
else
begin
{ Method's own type params: function Identity<T>(...) }
Result.TypeParams := TempParams;
TempParams := nil;
Result.TypeParams := TempParams;
Result.TypeParamConstraints := TempConstraints;
TempParams := nil;
TempConstraints := nil;
end;
finally
TempParams.Free;
TempConstraints.Free;
end;
end;
{ Qualified name: TypeName.MethodName or TypeName<T>.MethodName }
@ -854,6 +922,24 @@ begin
Exit;
end;
if Check(tkExit) then
begin
Result := TExitStmt.Create;
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
Advance;
Exit;
end;
if Check(tkBreak) then
begin
Result := TBreakStmt.Create;
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
Advance;
Exit;
end;
if Check(tkBegin) then
begin
Result := ParseCompoundStmt;
@ -1328,9 +1414,11 @@ var
Node: TBinaryExpr;
begin
Result := ParseTerm;
while Check(tkPlus) or Check(tkMinus) do
while Check(tkPlus) or Check(tkMinus) or Check(tkOr) do
begin
if Check(tkPlus) then Op := boAdd else Op := boSub;
if Check(tkPlus) then Op := boAdd
else if Check(tkMinus) then Op := boSub
else Op := boOr;
Advance;
Right := ParseTerm;
Node := TBinaryExpr.Create;
@ -1348,9 +1436,11 @@ var
Node: TBinaryExpr;
begin
Result := ParseFactor;
while Check(tkStar) or Check(tkSlash) or Check(tkDiv) do
while Check(tkStar) or Check(tkSlash) or Check(tkDiv) or Check(tkAnd) do
begin
if Check(tkStar) then Op := boMul else Op := boDiv;
if Check(tkStar) then Op := boMul
else if Check(tkAnd) then Op := boAnd
else Op := boDiv;
Advance;
Right := ParseFactor;
Node := TBinaryExpr.Create;
@ -1371,6 +1461,7 @@ var
MCallNode: TMethodCallExpr;
FCallNode: TFuncCallExpr;
DerefNode: TDerefExpr;
NotNode: TNotExpr;
Inner: TASTExpr;
Name: string;
SecondName: string;
@ -1379,6 +1470,15 @@ var
NegNode: TBinaryExpr;
begin
case FCurrent.Kind of
tkNot:
begin
NotNode := TNotExpr.Create;
NotNode.Line := FCurrent.Line;
NotNode.Col := FCurrent.Col;
Advance; { consume 'not' }
NotNode.Expr := Self.ParseFactor; { Self. forces recursive call }
Result := NotNode;
end;
tkMinus:
begin
{ Unary minus: synthesise as 0 - Factor }
@ -1489,6 +1589,18 @@ begin
FldNode.RecordName := Name;
FldNode.FieldName := SecondName;
Result := FldNode;
{ Chained access: A.B.C.D ... — wrap each subsequent '.IDENT' }
while Check(tkDot) and (PeekKind = tkIdent) do
begin
Advance; { consume '.' }
FldNode := TFieldAccessExpr.Create;
FldNode.Line := FCurrent.Line;
FldNode.Col := FCurrent.Col;
FldNode.Base := Result;
FldNode.FieldName := FCurrent.Value;
Advance; { consume field name }
Result := FldNode;
end;
end;
end
else if Check(tkLParen) then

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

@ -34,6 +34,7 @@ type
FMethodIndex: TStringList; { 'TypeName.MethodName' → TMethodDecl (not owned) }
FProcIndex: TStringList; { 'ProcName' → TMethodDecl (not owned) }
FGenericFuncTemplates: TStringList; { base name → TMethodDecl template (not owned) }
FLoopDepth: Integer; { depth of enclosing while/for — Break only legal if > 0 }
{ Generic type instantiation: resolves 'TBox<Integer>' on demand. }
function FindTypeOrInstantiate(const AName: string): TTypeDesc;
@ -79,6 +80,11 @@ type
const AContext: string; ALine, ACol: Integer);
{ Returns True if AActual is AExpected or a subclass of AExpected. }
function IsSubtypeOf(AActual, AExpected: TTypeDesc): Boolean;
{ Validates a generic type parameter's constraint against a concrete type
argument name. Raises ESemanticError on constraint violation.
AConstraint: '' (no constraint), 'class', 'record', or a type name. }
procedure CheckTypeParamConstraint(const AParamName, AArgName, AConstraint,
AContext: string);
public
constructor Create;
destructor Destroy; override;
@ -98,6 +104,7 @@ begin
FProcIndex.CaseSensitive := False;
FGenericFuncTemplates := TStringList.Create;
FGenericFuncTemplates.CaseSensitive := False;
FLoopDepth := 0;
end;
destructor TSemanticAnalyser.Destroy;
@ -114,6 +121,82 @@ begin
raise ESemanticError.CreateFmt('%s at line %d col %d', [AMsg, ALine, ACol]);
end;
procedure TSemanticAnalyser.CheckTypeParamConstraint(
const AParamName, AArgName, AConstraint, AContext: string);
var
ArgType: TTypeDesc;
ConstrType: TTypeDesc;
RT: TRecordTypeDesc;
I: Integer;
Implements: Boolean;
begin
if AConstraint = '' then Exit;
ArgType := FTable.FindType(AArgName);
if ArgType = nil then
raise ESemanticError.CreateFmt(
'Unknown type ''%s'' for type parameter ''%s'' in %s',
[AArgName, AParamName, AContext]);
if SameText(AConstraint, 'class') then
begin
if ArgType.Kind <> tyClass then
raise ESemanticError.CreateFmt(
'Type ''%s'' does not satisfy constraint ''%s: class'' in %s',
[AArgName, AParamName, AContext]);
Exit;
end;
if SameText(AConstraint, 'record') then
begin
if not (ArgType.Kind in [tyRecord, tyInteger, tyInt64, tyUInt32, tyByte,
tyBoolean, tyString, tyPointer]) then
raise ESemanticError.CreateFmt(
'Type ''%s'' does not satisfy constraint ''%s: record'' in %s',
[AArgName, AParamName, AContext]);
Exit;
end;
{ Named constraint: T : SomeType. Concrete type must BE that type or —
for classes/interfaces — inherit from / implement it. }
ConstrType := FTable.FindType(AConstraint);
if ConstrType = nil then
raise ESemanticError.CreateFmt(
'Unknown constraint type ''%s'' for type parameter ''%s'' in %s',
[AConstraint, AParamName, AContext]);
if ArgType = ConstrType then Exit;
if (ConstrType.Kind = tyClass) and (ArgType.Kind = tyClass) then
begin
if IsSubtypeOf(ArgType, ConstrType) then Exit;
raise ESemanticError.CreateFmt(
'Type ''%s'' does not inherit from ''%s'' (constraint ''%s: %s'') in %s',
[AArgName, AConstraint, AParamName, AConstraint, AContext]);
end;
if (ConstrType.Kind = tyInterface) and (ArgType.Kind = tyClass) then
begin
RT := TRecordTypeDesc(ArgType);
Implements := False;
for I := 0 to RT.ImplementsCount - 1 do
if RT.ImplementsIntfAt(I) = ConstrType then
begin
Implements := True;
Break;
end;
if not Implements then
raise ESemanticError.CreateFmt(
'Type ''%s'' does not implement ''%s'' (constraint ''%s: %s'') in %s',
[AArgName, AConstraint, AParamName, AConstraint, AContext]);
Exit;
end;
raise ESemanticError.CreateFmt(
'Type ''%s'' does not satisfy constraint ''%s: %s'' in %s',
[AArgName, AParamName, AConstraint, AContext]);
end;
function TSemanticAnalyser.IsSubtypeOf(AActual, AExpected: TTypeDesc): Boolean;
var
Walk: TRecordTypeDesc;
@ -508,6 +591,13 @@ begin
if Templ = nil then Exit;
if Args.Count <> Templ.ParamNames.Count then Exit;
{ Validate each type argument against its declared constraint. }
for I := 0 to Args.Count - 1 do
if (Templ.ParamConstraints <> nil) and (I < Templ.ParamConstraints.Count) then
CheckTypeParamConstraint(Templ.ParamNames[I], Args[I],
Templ.ParamConstraints[I],
Format('instantiation ''%s''', [ATypeName]));
{ Create the concrete class type descriptor — defined globally so the
symbol survives scope pops and is visible after analysis completes. }
RT := FTable.NewClassType(ATypeName);
@ -702,6 +792,12 @@ begin
Templ := TGenericInterfaceDef(TemplObj);
if Args.Count <> Templ.ParamNames.Count then Exit;
for I := 0 to Args.Count - 1 do
if (Templ.ParamConstraints <> nil) and (I < Templ.ParamConstraints.Count) then
CheckTypeParamConstraint(Templ.ParamNames[I], Args[I],
Templ.ParamConstraints[I],
Format('interface instantiation ''%s''', [ATypeName]));
{ Check if already instantiated }
Sym := FTable.Lookup(ATypeName);
if (Sym <> nil) and (Sym.TypeDesc is TInterfaceTypeDesc) then
@ -786,6 +882,14 @@ begin
[BaseName, Templ.TypeParams.Count, Args.Count]),
0, 0);
{ Validate each type argument against the template's declared constraints. }
for I := 0 to Args.Count - 1 do
if (Templ.TypeParamConstraints <> nil) and
(I < Templ.TypeParamConstraints.Count) then
CheckTypeParamConstraint(Templ.TypeParams[I], Args[I],
Templ.TypeParamConstraints[I],
Format('generic function ''%s''', [AInstName]));
NewMDecl := TMethodDecl.Create;
NewMDecl.Name := AInstName;
NewMDecl.OwnBody := False; { share the template body }
@ -1499,7 +1603,12 @@ begin
EndType := AnalyseExpr(ForS.EndExpr);
CheckTypesMatch(VarSym.TypeDesc, EndType,
'for-loop end expression', ForS.Line, ForS.Col);
AnalyseStmt(ForS.Body);
Inc(FLoopDepth);
try
AnalyseStmt(ForS.Body);
finally
Dec(FLoopDepth);
end;
end
else if AStmt is TWhileStmt then
begin
@ -1510,9 +1619,24 @@ begin
SemanticError(
Format('while condition must be Boolean, got ''%s''', [CondType.Name]),
AStmt.Line, AStmt.Col);
AnalyseStmt(Body);
Inc(FLoopDepth);
try
AnalyseStmt(Body);
finally
Dec(FLoopDepth);
end;
end;
end
else if AStmt is TExitStmt then
begin
{ No semantic checks needed — a bare 'exit' is valid in any method or
the main program block. }
end
else if AStmt is TBreakStmt then
begin
if FLoopDepth = 0 then
SemanticError('''break'' is not inside a loop', AStmt.Line, AStmt.Col);
end
else if AStmt is TIfStmt then
begin
IfS := TIfStmt(AStmt);
@ -2007,6 +2131,15 @@ begin
Result := AnalyseAsExpr(TAsExpr(AExpr))
else if AExpr is TDerefExpr then
Result := AnalyseDerefExpr(TDerefExpr(AExpr))
else if AExpr is TNotExpr then
begin
Result := AnalyseExpr(TNotExpr(AExpr).Expr);
if Result.Kind <> tyBoolean then
SemanticError(
Format('''not'' requires a Boolean operand, got ''%s''', [Result.Name]),
AExpr.Line, AExpr.Col);
Result := FTable.TypeBoolean;
end
else
SemanticError('Unknown expression node', AExpr.Line, AExpr.Col);
@ -2019,7 +2152,42 @@ var
RT: TRecordTypeDesc;
FldInfo: TFieldInfo;
PropInfo: TPropertyInfo;
BaseType: TTypeDesc;
begin
{ Chained access: A.B.C — base is another expression whose type must be
a record or class. Leaf lookup uses Base.ResolvedType; RecordName path
(no Base) is used only for the simple IDENT.IDENT form. }
if AAccess.Base <> nil then
begin
BaseType := AnalyseExpr(AAccess.Base);
if not (BaseType.Kind in [tyRecord, tyClass]) then
SemanticError(
Format('Field access ''.%s'' requires a record or class base, got ''%s''',
[AAccess.FieldName, BaseType.Name]),
AAccess.Line, AAccess.Col);
AAccess.IsClassAccess := BaseType.Kind = tyClass;
RT := TRecordTypeDesc(BaseType);
FldInfo := RT.FindField(AAccess.FieldName);
if FldInfo = nil then
begin
PropInfo := RT.FindProperty(AAccess.FieldName);
if (PropInfo <> nil) and (PropInfo.ReadField <> '') then
begin
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
Result := PropInfo.TypeDesc;
Exit;
end;
SemanticError(
Format('Type ''%s'' has no field ''%s''',
[BaseType.Name, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
end;
AAccess.FieldInfo := FldInfo;
Result := FldInfo.TypeDesc;
Exit;
end;
RecSym := FTable.Lookup(AAccess.RecordName);
if RecSym = nil then
SemanticError(
@ -2101,6 +2269,23 @@ begin
LType := AnalyseExpr(ABin.Left);
RType := AnalyseExpr(ABin.Right);
{ Logical AND / OR — both operands must be Boolean. }
if ABin.Op in [boAnd, boOr] then
begin
if LType.Kind <> tyBoolean then
SemanticError(
Format('Left operand of ''%s'' must be Boolean, got ''%s''',
[BinaryOpName(ABin.Op), LType.Name]),
ABin.Line, ABin.Col);
if RType.Kind <> tyBoolean then
SemanticError(
Format('Right operand of ''%s'' must be Boolean, got ''%s''',
[BinaryOpName(ABin.Op), RType.Name]),
ABin.Line, ABin.Col);
Result := FTable.TypeBoolean;
Exit;
end;
if IsComparisonOp(ABin.Op) then
begin
{ nil can be compared with class, interface, or pointer types }

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

@ -46,6 +46,11 @@ uses
cp.test.genericdefaults,
cp.test.genericmethodimpls,
cp.test.tdictionary,
cp.test.booleanops,
cp.test.flowjumps,
cp.test.multiwrite,
cp.test.chainedfields,
cp.test.genericconstraints,
cp.test.e2e;
var

240
compiler/src/test/pascal/cp.test.booleanops.pas Normal file
View file

@ -0,0 +1,240 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: BSD-3-Clause
See LICENSE file in the project root for full license terms.
}
unit cp.test.booleanops;
{$mode objfpc}{$H+}
{ Tests for the AND / OR / NOT logical operators on Boolean operands. }
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TBooleanOpsTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
published
procedure TestLexer_And_Keyword;
procedure TestLexer_Or_Keyword;
procedure TestLexer_Not_Keyword;
procedure TestParse_And_IsBinaryExpr;
procedure TestParse_Or_IsBinaryExpr;
procedure TestParse_Not_IsNotExpr;
procedure TestSemantic_And_TypeIsBoolean;
procedure TestSemantic_Or_TypeIsBoolean;
procedure TestSemantic_Not_TypeIsBoolean;
procedure TestSemantic_And_IntOperand_RaisesError;
procedure TestSemantic_Not_IntOperand_RaisesError;
procedure TestCodegen_And_EmitsAnd;
procedure TestCodegen_Or_EmitsOr;
procedure TestCodegen_Not_EmitsXor;
end;
implementation
function TBooleanOpsTests.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 TBooleanOpsTests.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 TBooleanOpsTests.GenIR(const ASrc: string): string;
var Prog: TProgram; CG: TCodeGenQBE;
begin
Prog := AnalyseSrc(ASrc);
try
CG := TCodeGenQBE.Create;
try CG.Generate(Prog); Result := CG.GetOutput; finally CG.Free; end;
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.AnalyseExpectError(const ASrc: string);
var Prog: TProgram;
begin
try
Prog := AnalyseSrc(ASrc);
Prog.Free;
Fail('Expected ESemanticError');
except
on E: ESemanticError do ;
end;
end;
const
SrcAnd =
'program P;' + LineEnding +
'var A, B: Boolean; C: Boolean;' + LineEnding +
'begin' + LineEnding +
' A := True;' + LineEnding +
' B := False;' + LineEnding +
' C := A and B' + LineEnding +
'end.';
SrcOr =
'program P;' + LineEnding +
'var A, B: Boolean; C: Boolean;' + LineEnding +
'begin' + LineEnding +
' A := True;' + LineEnding +
' B := False;' + LineEnding +
' C := A or B' + LineEnding +
'end.';
SrcNot =
'program P;' + LineEnding +
'var A: Boolean; C: Boolean;' + LineEnding +
'begin' + LineEnding +
' A := True;' + LineEnding +
' C := not A' + LineEnding +
'end.';
procedure TBooleanOpsTests.TestLexer_And_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('and');
try T := L.Next; AssertEquals(Ord(tkAnd), Ord(T.Kind)); finally L.Free; end;
end;
procedure TBooleanOpsTests.TestLexer_Or_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('or');
try T := L.Next; AssertEquals(Ord(tkOr), Ord(T.Kind)); finally L.Free; end;
end;
procedure TBooleanOpsTests.TestLexer_Not_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('not');
try T := L.Next; AssertEquals(Ord(tkNot), Ord(T.Kind)); finally L.Free; end;
end;
procedure TBooleanOpsTests.TestParse_And_IsBinaryExpr;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := ParseSrc(SrcAnd);
try
Assn := TAssignment(Prog.Block.Stmts[2]);
AssertTrue('and is binary expr', Assn.Expr is TBinaryExpr);
AssertEquals('and op', Ord(boAnd), Ord(TBinaryExpr(Assn.Expr).Op));
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.TestParse_Or_IsBinaryExpr;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := ParseSrc(SrcOr);
try
Assn := TAssignment(Prog.Block.Stmts[2]);
AssertTrue(Assn.Expr is TBinaryExpr);
AssertEquals(Ord(boOr), Ord(TBinaryExpr(Assn.Expr).Op));
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.TestParse_Not_IsNotExpr;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := ParseSrc(SrcNot);
try
Assn := TAssignment(Prog.Block.Stmts[1]);
AssertTrue('not is TNotExpr', Assn.Expr is TNotExpr);
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.TestSemantic_And_TypeIsBoolean;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := AnalyseSrc(SrcAnd);
try
Assn := TAssignment(Prog.Block.Stmts[2]);
AssertEquals(Ord(tyBoolean), Ord(Assn.Expr.ResolvedType.Kind));
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.TestSemantic_Or_TypeIsBoolean;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := AnalyseSrc(SrcOr);
try
Assn := TAssignment(Prog.Block.Stmts[2]);
AssertEquals(Ord(tyBoolean), Ord(Assn.Expr.ResolvedType.Kind));
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.TestSemantic_Not_TypeIsBoolean;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := AnalyseSrc(SrcNot);
try
Assn := TAssignment(Prog.Block.Stmts[1]);
AssertEquals(Ord(tyBoolean), Ord(Assn.Expr.ResolvedType.Kind));
finally Prog.Free; end;
end;
procedure TBooleanOpsTests.TestSemantic_And_IntOperand_RaisesError;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'var I, J: Integer; C: Boolean;' + LineEnding +
'begin' + LineEnding +
' I := 1; J := 2;' + LineEnding +
' C := I and J' + LineEnding +
'end.');
end;
procedure TBooleanOpsTests.TestSemantic_Not_IntOperand_RaisesError;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'var I: Integer; C: Boolean;' + LineEnding +
'begin' + LineEnding +
' I := 1;' + LineEnding +
' C := not I' + LineEnding +
'end.');
end;
procedure TBooleanOpsTests.TestCodegen_And_EmitsAnd;
var IR: string;
begin
IR := GenIR(SrcAnd);
AssertTrue('emits =w and', Pos('=w and ', IR) > 0);
end;
procedure TBooleanOpsTests.TestCodegen_Or_EmitsOr;
var IR: string;
begin
IR := GenIR(SrcOr);
AssertTrue('emits =w or', Pos('=w or ', IR) > 0);
end;
procedure TBooleanOpsTests.TestCodegen_Not_EmitsXor;
var IR: string;
begin
IR := GenIR(SrcNot);
AssertTrue('emits xor', Pos('xor ', IR) > 0);
end;
initialization
RegisterTest(TBooleanOpsTests);
end.

167
compiler/src/test/pascal/cp.test.chainedfields.pas Normal file
View file

@ -0,0 +1,167 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: BSD-3-Clause
See LICENSE file in the project root for full license terms.
}
unit cp.test.chainedfields;
{$mode objfpc}{$H+}
{ Tests for chained field access expressions: A.B.C and deeper. }
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TChainedFieldTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
published
procedure TestParse_TwoDots_HasBase;
procedure TestParse_ThreeDots_HasNestedBases;
procedure TestSemantic_RecordChain_ResolvesToInnerType;
procedure TestSemantic_ClassFieldThenRecordField_Resolves;
procedure TestCodegen_RecordChain_EmitsLoadw;
end;
implementation
function TChainedFieldTests.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 TChainedFieldTests.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 TChainedFieldTests.GenIR(const ASrc: string): string;
var Prog: TProgram; CG: TCodeGenQBE;
begin
Prog := AnalyseSrc(ASrc);
try
CG := TCodeGenQBE.Create;
try CG.Generate(Prog); Result := CG.GetOutput; finally CG.Free; end;
finally Prog.Free; end;
end;
const
SrcTwoDeep =
'program P;' + LineEnding +
'type' + LineEnding +
' TInner = record' + LineEnding +
' Value: Integer;' + LineEnding +
' end;' + LineEnding +
' TOuter = record' + LineEnding +
' Inner: TInner;' + LineEnding +
' end;' + LineEnding +
'var O: TOuter; N: Integer;' + LineEnding +
'begin' + LineEnding +
' N := O.Inner.Value' + LineEnding +
'end.';
SrcThreeDeep =
'program P;' + LineEnding +
'type' + LineEnding +
' TA = record X: Integer; end;' + LineEnding +
' TB = record A: TA; end;' + LineEnding +
' TC = record B: TB; end;' + LineEnding +
'var C: TC; N: Integer;' + LineEnding +
'begin' + LineEnding +
' N := C.B.A.X' + LineEnding +
'end.';
SrcClassFieldOfRecord =
'program P;' + LineEnding +
'type' + LineEnding +
' TThing = class(TObject)' + LineEnding +
' Inner: Integer;' + LineEnding +
' end;' + LineEnding +
' TBox = record' + LineEnding +
' Thing: TThing;' + LineEnding +
' end;' + LineEnding +
'var B: TBox; N: Integer; T: TThing;' + LineEnding +
'begin' + LineEnding +
' B.Thing := TThing.Create;' + LineEnding +
' N := B.Thing.Inner;' + LineEnding +
' T := B.Thing;' + LineEnding +
' T.Free' + LineEnding +
'end.';
procedure TChainedFieldTests.TestParse_TwoDots_HasBase;
var Prog: TProgram; Assn: TAssignment; Fld: TFieldAccessExpr;
begin
Prog := ParseSrc(SrcTwoDeep);
try
Assn := TAssignment(Prog.Block.Stmts[0]);
AssertTrue('rhs is field access', Assn.Expr is TFieldAccessExpr);
Fld := TFieldAccessExpr(Assn.Expr);
AssertEquals('outer field name', 'Value', Fld.FieldName);
AssertNotNull('has Base', Fld.Base);
AssertTrue('base is field access', Fld.Base is TFieldAccessExpr);
AssertEquals('inner field name', 'Inner',
TFieldAccessExpr(Fld.Base).FieldName);
finally Prog.Free; end;
end;
procedure TChainedFieldTests.TestParse_ThreeDots_HasNestedBases;
var Prog: TProgram; Assn: TAssignment; Fld: TFieldAccessExpr;
begin
Prog := ParseSrc(SrcThreeDeep);
try
Assn := TAssignment(Prog.Block.Stmts[0]);
Fld := TFieldAccessExpr(Assn.Expr);
AssertEquals('leaf field', 'X', Fld.FieldName);
AssertTrue('base 1 is field access', Fld.Base is TFieldAccessExpr);
AssertEquals('mid field', 'A', TFieldAccessExpr(Fld.Base).FieldName);
AssertTrue('base 2 is field access',
TFieldAccessExpr(Fld.Base).Base is TFieldAccessExpr);
AssertEquals('base field', 'B',
TFieldAccessExpr(TFieldAccessExpr(Fld.Base).Base).FieldName);
finally Prog.Free; end;
end;
procedure TChainedFieldTests.TestSemantic_RecordChain_ResolvesToInnerType;
var Prog: TProgram; Assn: TAssignment;
begin
Prog := AnalyseSrc(SrcTwoDeep);
try
Assn := TAssignment(Prog.Block.Stmts[0]);
AssertEquals('chain type is Integer',
Ord(tyInteger), Ord(Assn.Expr.ResolvedType.Kind));
finally Prog.Free; end;
end;
procedure TChainedFieldTests.TestSemantic_ClassFieldThenRecordField_Resolves;
var Prog: TProgram;
begin
Prog := AnalyseSrc(SrcClassFieldOfRecord);
try AssertNotNull(Prog); finally Prog.Free; end;
end;
procedure TChainedFieldTests.TestCodegen_RecordChain_EmitsLoadw;
var IR: string;
begin
IR := GenIR(SrcTwoDeep);
AssertTrue('emits loadw for inner integer field',
Pos('loadw', IR) > 0);
end;
initialization
RegisterTest(TChainedFieldTests);
end.

142
compiler/src/test/pascal/cp.test.e2e.pas
View file

@ -75,6 +75,14 @@ type
{ Valgrind-clean: no leaks and no errors on the milestone program.
Skipped (not failed) when valgrind is absent. }
procedure TestRun_Phase2Milestone_Valgrind;
{ Smoke tests for the features added alongside this suite:
AND/OR/NOT, Exit/Break, multi-arg WriteLn, chained field access. }
procedure TestRun_BooleanOps_AllExpressions;
procedure TestRun_MultiArgWriteLn_PrintsAllArgs;
procedure TestRun_ForBreak_StopsAtFiveHalt;
procedure TestRun_ExitFromFunction_ReturnsImmediately;
procedure TestRun_ChainedRecordField_LoadsInner;
end;
implementation
@ -564,6 +572,140 @@ begin
end;
end;
{ ------------------------------------------------------------------ }
{ New-feature smoke tests (AND/OR/NOT, Exit/Break, multi-arg WriteLn,
chained field access). Kept here rather than a dedicated unit so
all compile+run coverage lives together. }
{ ------------------------------------------------------------------ }
const
SrcBoolOps =
'program P;' + LE +
'var A, B: Boolean;' + LE +
'begin' + LE +
' A := True;' + LE +
' B := False;' + LE +
' if A and not B then WriteLn(''t1'');' + LE +
' if A or B then WriteLn(''t2'');' + LE +
' if not (A and B) then WriteLn(''t3'')' + LE +
'end.';
SrcMultiArg =
'program P;' + LE +
'var I, J, K: Integer;' + LE +
'begin' + LE +
' I := 1; J := 2; K := 3;' + LE +
' WriteLn(I, J, K)' + LE +
'end.';
SrcForBreak =
'program P;' + LE +
'var I, Last: Integer;' + LE +
'begin' + LE +
' Last := 0;' + LE +
' for I := 1 to 100 do' + LE +
' begin' + LE +
' Last := I;' + LE +
' if I = 5 then break' + LE +
' end;' + LE +
' WriteLn(Last)' + LE +
'end.';
SrcExitFunc =
'program P;' + LE +
'function FirstPositive(X: Integer): Integer;' + LE +
'begin' + LE +
' if X > 0 then' + LE +
' begin Result := X; exit end;' + LE +
' Result := 0 - X' + LE +
'end;' + LE +
'begin' + LE +
' WriteLn(FirstPositive(7));' + LE +
' WriteLn(FirstPositive(0 - 9))' + LE +
'end.';
{ Chained READ: Pascal zero-initialises records, so O.I.Value defaults
to 0 without any write. Exercising the read path is enough for this
smoke test; chained-WRITE support is tracked separately. }
SrcChainedRecord =
'program P;' + LE +
'type' + LE +
' TInner = record Value: Integer; end;' + LE +
' TOuter = record I: TInner; end;' + LE +
'var O: TOuter; N: Integer;' + LE +
'begin' + LE +
' N := O.I.Value;' + LE +
' WriteLn(N)' + LE +
'end.';
procedure TE2ETests.TestRun_BooleanOps_AllExpressions;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then
begin
Ignore('qbe or RTL not built');
Exit;
end;
AssertTrue(CompileAndRun(SrcBoolOps, Output, RCode, []));
AssertEquals('exit 0', 0, RCode);
AssertEquals('all three branches fire',
't1' + LE + 't2' + LE + 't3' + LE, Output);
end;
procedure TE2ETests.TestRun_MultiArgWriteLn_PrintsAllArgs;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then
begin
Ignore('qbe or RTL not built');
Exit;
end;
AssertTrue(CompileAndRun(SrcMultiArg, Output, RCode, []));
AssertEquals('exit 0', 0, RCode);
AssertEquals('three values concatenated with trailing newline',
'123' + LE, Output);
end;
procedure TE2ETests.TestRun_ForBreak_StopsAtFiveHalt;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then
begin
Ignore('qbe or RTL not built');
Exit;
end;
AssertTrue(CompileAndRun(SrcForBreak, Output, RCode, []));
AssertEquals('exit 0', 0, RCode);
AssertEquals('loop broke at I=5', '5' + LE, Output);
end;
procedure TE2ETests.TestRun_ExitFromFunction_ReturnsImmediately;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then
begin
Ignore('qbe or RTL not built');
Exit;
end;
AssertTrue(CompileAndRun(SrcExitFunc, Output, RCode, []));
AssertEquals('exit 0', 0, RCode);
AssertEquals('exit early for positive, compute for negative',
'7' + LE + '9' + LE, Output);
end;
procedure TE2ETests.TestRun_ChainedRecordField_LoadsInner;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then
begin
Ignore('qbe or RTL not built');
Exit;
end;
AssertTrue(CompileAndRun(SrcChainedRecord, Output, RCode, []));
AssertEquals('exit 0', 0, RCode);
AssertEquals('chained read of zero-initialised field', '0' + LE, Output);
end;
initialization
RegisterTest(TE2ETests);

225
compiler/src/test/pascal/cp.test.flowjumps.pas Normal file
View file

@ -0,0 +1,225 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: BSD-3-Clause
See LICENSE file in the project root for full license terms.
}
unit cp.test.flowjumps;
{$mode objfpc}{$H+}
{ Tests for non-local flow statements: Exit and Break. }
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TFlowJumpsTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
published
procedure TestLexer_Exit_Keyword;
procedure TestLexer_Break_Keyword;
procedure TestParse_Exit_IsExitStmt;
procedure TestParse_Break_IsBreakStmt;
procedure TestSemantic_Break_OutsideLoop_RaisesError;
procedure TestSemantic_Break_InsideFor_Resolves;
procedure TestSemantic_Break_InsideWhile_Resolves;
procedure TestCodegen_Exit_EmitsJmpToExitLabel;
procedure TestCodegen_Break_InFor_EmitsJmpToLoopEnd;
procedure TestCodegen_Break_InWhile_EmitsJmpToLoopEnd;
procedure TestCodegen_Exit_FromFunction_JumpsToFuncExit;
end;
implementation
function TFlowJumpsTests.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 TFlowJumpsTests.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 TFlowJumpsTests.GenIR(const ASrc: string): string;
var Prog: TProgram; CG: TCodeGenQBE;
begin
Prog := AnalyseSrc(ASrc);
try
CG := TCodeGenQBE.Create;
try CG.Generate(Prog); Result := CG.GetOutput; finally CG.Free; end;
finally Prog.Free; end;
end;
procedure TFlowJumpsTests.AnalyseExpectError(const ASrc: string);
var Prog: TProgram;
begin
try
Prog := AnalyseSrc(ASrc);
Prog.Free;
Fail('Expected ESemanticError');
except
on E: ESemanticError do ;
end;
end;
const
SrcExit =
'program P;' + LineEnding +
'var I: Integer;' + LineEnding +
'begin' + LineEnding +
' I := 1;' + LineEnding +
' if I = 1 then exit;' + LineEnding +
' I := 2' + LineEnding +
'end.';
SrcBreakInFor =
'program P;' + LineEnding +
'var I: Integer;' + LineEnding +
'begin' + LineEnding +
' for I := 1 to 10 do' + LineEnding +
' begin' + LineEnding +
' if I > 5 then break' + LineEnding +
' end' + LineEnding +
'end.';
SrcBreakInWhile =
'program P;' + LineEnding +
'var I: Integer;' + LineEnding +
'begin' + LineEnding +
' I := 0;' + LineEnding +
' while I < 100 do' + LineEnding +
' begin' + LineEnding +
' if I = 5 then break;' + LineEnding +
' I := I + 1' + LineEnding +
' end' + LineEnding +
'end.';
SrcBreakOutsideLoop =
'program P;' + LineEnding +
'var I: Integer;' + LineEnding +
'begin' + LineEnding +
' I := 0;' + LineEnding +
' break' + LineEnding +
'end.';
SrcExitFromFunc =
'program P;' + LineEnding +
'function Abs1(X: Integer): Integer;' + LineEnding +
'begin' + LineEnding +
' if X < 0 then' + LineEnding +
' begin Result := 0 - X; exit end;' + LineEnding +
' Result := X' + LineEnding +
'end;' + LineEnding +
'var N: Integer;' + LineEnding +
'begin' + LineEnding +
' N := Abs1(-7)' + LineEnding +
'end.';
procedure TFlowJumpsTests.TestLexer_Exit_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('exit');
try T := L.Next; AssertEquals(Ord(tkExit), Ord(T.Kind)); finally L.Free; end;
end;
procedure TFlowJumpsTests.TestLexer_Break_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('break');
try T := L.Next; AssertEquals(Ord(tkBreak), Ord(T.Kind)); finally L.Free; end;
end;
procedure TFlowJumpsTests.TestParse_Exit_IsExitStmt;
var Prog: TProgram; IfS: TIfStmt;
begin
Prog := ParseSrc(SrcExit);
try
IfS := TIfStmt(Prog.Block.Stmts[1]);
AssertTrue('then body is TExitStmt', IfS.ThenStmt is TExitStmt);
finally Prog.Free; end;
end;
procedure TFlowJumpsTests.TestParse_Break_IsBreakStmt;
var
Prog: TProgram;
ForS: TForStmt;
Cmp: TCompoundStmt;
IfS: TIfStmt;
begin
Prog := ParseSrc(SrcBreakInFor);
try
ForS := TForStmt(Prog.Block.Stmts[0]);
Cmp := TCompoundStmt(ForS.Body);
IfS := TIfStmt(Cmp.Stmts[0]);
AssertTrue('then body is TBreakStmt', IfS.ThenStmt is TBreakStmt);
finally Prog.Free; end;
end;
procedure TFlowJumpsTests.TestSemantic_Break_OutsideLoop_RaisesError;
begin
AnalyseExpectError(SrcBreakOutsideLoop);
end;
procedure TFlowJumpsTests.TestSemantic_Break_InsideFor_Resolves;
var Prog: TProgram;
begin
Prog := AnalyseSrc(SrcBreakInFor);
try AssertNotNull(Prog); finally Prog.Free; end;
end;
procedure TFlowJumpsTests.TestSemantic_Break_InsideWhile_Resolves;
var Prog: TProgram;
begin
Prog := AnalyseSrc(SrcBreakInWhile);
try AssertNotNull(Prog); finally Prog.Free; end;
end;
procedure TFlowJumpsTests.TestCodegen_Exit_EmitsJmpToExitLabel;
var IR: string;
begin
IR := GenIR(SrcExit);
AssertTrue('emits jmp @main_exit', Pos('jmp @main_exit', IR) > 0);
AssertTrue('has @main_exit label', Pos('@main_exit', IR) > 0);
end;
procedure TFlowJumpsTests.TestCodegen_Break_InFor_EmitsJmpToLoopEnd;
var IR: string;
begin
IR := GenIR(SrcBreakInFor);
AssertTrue('emits jmp @for_end', Pos('jmp @for_end', IR) > 0);
end;
procedure TFlowJumpsTests.TestCodegen_Break_InWhile_EmitsJmpToLoopEnd;
var IR: string;
begin
IR := GenIR(SrcBreakInWhile);
AssertTrue('emits jmp @while_end', Pos('jmp @while_end', IR) > 0);
end;
procedure TFlowJumpsTests.TestCodegen_Exit_FromFunction_JumpsToFuncExit;
var IR: string;
begin
IR := GenIR(SrcExitFromFunc);
AssertTrue('emits func_exit label', Pos('@func_exit', IR) > 0);
end;
initialization
RegisterTest(TFlowJumpsTests);
end.

260
compiler/src/test/pascal/cp.test.genericconstraints.pas Normal file
View file

@ -0,0 +1,260 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: BSD-3-Clause
See LICENSE file in the project root for full license terms.
}
unit cp.test.genericconstraints;
{$mode objfpc}{$H+}
{ Tests for generic type parameter constraints:
<T: class> — T must be a class type
<T: record> — T must be a value type
<T: SomeTypeName> — T must be that type (or subclass / implementor). }
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TGenericConstraintTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
procedure AnalyseExpectError(const ASrc: string);
published
procedure TestParse_GenericType_ClassConstraint;
procedure TestParse_GenericType_RecordConstraint;
procedure TestParse_GenericType_NamedConstraint;
procedure TestParse_GenericType_TwoParamsWithMixedConstraints;
procedure TestParse_GenericFunc_ClassConstraint;
procedure TestParse_GenericFunc_NamedConstraint;
procedure TestSemantic_GenericFunc_ClassConstraint_Violation;
procedure TestSemantic_GenericFunc_ClassConstraint_Satisfied;
procedure TestSemantic_GenericType_ClassConstraint_Violation;
procedure TestSemantic_GenericFunc_NamedConstraint_Violation;
procedure TestSemantic_GenericFunc_NamedConstraint_Satisfied;
end;
implementation
function TGenericConstraintTests.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 TGenericConstraintTests.AnalyseSrc(const ASrc: string): TProgram;
var A: TSemanticAnalyser;
begin
Result := ParseSrc(ASrc);
A := TSemanticAnalyser.Create;
try A.Analyse(Result); finally A.Free; end;
end;
procedure TGenericConstraintTests.AnalyseExpectError(const ASrc: string);
var Prog: TProgram;
begin
try
Prog := AnalyseSrc(ASrc);
Prog.Free;
Fail('Expected ESemanticError');
except
on E: ESemanticError do ;
end;
end;
procedure TGenericConstraintTests.TestParse_GenericType_ClassConstraint;
var Prog: TProgram; TD: TTypeDecl; GD: TGenericTypeDef;
begin
Prog := ParseSrc(
'program P;' + LineEnding +
'type' + LineEnding +
' TBox<T: class> = class' + LineEnding +
' FItem: Integer;' + LineEnding +
' end;' + LineEnding +
'begin end.');
try
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
AssertTrue(TD.Def is TGenericTypeDef);
GD := TGenericTypeDef(TD.Def);
AssertEquals(1, GD.ParamNames.Count);
AssertEquals('T', GD.ParamNames[0]);
AssertEquals('class', GD.ParamConstraints[0]);
finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestParse_GenericType_RecordConstraint;
var Prog: TProgram; TD: TTypeDecl; GD: TGenericTypeDef;
begin
Prog := ParseSrc(
'program P;' + LineEnding +
'type' + LineEnding +
' TBox<T: record> = class' + LineEnding +
' FItem: Integer;' + LineEnding +
' end;' + LineEnding +
'begin end.');
try
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
GD := TGenericTypeDef(TD.Def);
AssertEquals('record', GD.ParamConstraints[0]);
finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestParse_GenericType_NamedConstraint;
var Prog: TProgram; TD: TTypeDecl; GD: TGenericTypeDef;
begin
Prog := ParseSrc(
'program P;' + LineEnding +
'type' + LineEnding +
' TAnimal = class(TObject) X: Integer; end;' + LineEnding +
' TPen<T: TAnimal> = class' + LineEnding +
' FCount: Integer;' + LineEnding +
' end;' + LineEnding +
'begin end.');
try
TD := TTypeDecl(Prog.Block.TypeDecls[1]);
GD := TGenericTypeDef(TD.Def);
AssertEquals('TAnimal', GD.ParamConstraints[0]);
finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestParse_GenericType_TwoParamsWithMixedConstraints;
var Prog: TProgram; TD: TTypeDecl; GD: TGenericTypeDef;
begin
Prog := ParseSrc(
'program P;' + LineEnding +
'type' + LineEnding +
' TPair<K, V: class> = class' + LineEnding +
' FKey: Integer;' + LineEnding +
' end;' + LineEnding +
'begin end.');
try
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
GD := TGenericTypeDef(TD.Def);
AssertEquals(2, GD.ParamNames.Count);
AssertEquals('', GD.ParamConstraints[0]); { K unconstrained }
AssertEquals('class', GD.ParamConstraints[1]);
finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestParse_GenericFunc_ClassConstraint;
var Prog: TProgram; MD: TMethodDecl;
begin
Prog := ParseSrc(
'program P;' + LineEnding +
'function Id<T: class>(A: T): T;' + LineEnding +
'begin Result := A end;' + LineEnding +
'begin end.');
try
MD := TMethodDecl(Prog.Block.ProcDecls[0]);
AssertNotNull(MD.TypeParams);
AssertEquals('class', MD.TypeParamConstraints[0]);
finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestParse_GenericFunc_NamedConstraint;
var Prog: TProgram; MD: TMethodDecl;
begin
Prog := ParseSrc(
'program P;' + LineEnding +
'type TAnimal = class(TObject) X: Integer; end;' + LineEnding +
'function Box<T: TAnimal>(A: T): Integer;' + LineEnding +
'begin Result := 0 end;' + LineEnding +
'begin end.');
try
MD := TMethodDecl(Prog.Block.ProcDecls[0]);
AssertEquals('TAnimal', MD.TypeParamConstraints[0]);
finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestSemantic_GenericFunc_ClassConstraint_Violation;
begin
{ Integer is not a class — must raise }
AnalyseExpectError(
'program P;' + LineEnding +
'function Id<T: class>(A: T): T;' + LineEnding +
'begin Result := A end;' + LineEnding +
'var N: Integer;' + LineEnding +
'begin' + LineEnding +
' N := Id<Integer>(5)' + LineEnding +
'end.');
end;
procedure TGenericConstraintTests.TestSemantic_GenericFunc_ClassConstraint_Satisfied;
var Prog: TProgram;
begin
Prog := AnalyseSrc(
'program P;' + LineEnding +
'type TAnimal = class(TObject) X: Integer; end;' + LineEnding +
'function Id<T: class>(A: T): T;' + LineEnding +
'begin Result := A end;' + LineEnding +
'var A: TAnimal;' + LineEnding +
'begin' + LineEnding +
' A := TAnimal.Create;' + LineEnding +
' A := Id<TAnimal>(A);' + LineEnding +
' A.Free' + LineEnding +
'end.');
try AssertNotNull(Prog); finally Prog.Free; end;
end;
procedure TGenericConstraintTests.TestSemantic_GenericType_ClassConstraint_Violation;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'type' + LineEnding +
' TBox<T: class> = class' + LineEnding +
' FItem: Integer;' + LineEnding +
' end;' + LineEnding +
'var B: TBox<Integer>;' + LineEnding +
'begin end.');
end;
procedure TGenericConstraintTests.TestSemantic_GenericFunc_NamedConstraint_Violation;
begin
{ TCat does not inherit from TDog → must raise }
AnalyseExpectError(
'program P;' + LineEnding +
'type' + LineEnding +
' TDog = class(TObject) X: Integer; end;' + LineEnding +
' TCat = class(TObject) Y: Integer; end;' + LineEnding +
'function Use<T: TDog>(A: T): Integer;' + LineEnding +
'begin Result := 0 end;' + LineEnding +
'var C: TCat; N: Integer;' + LineEnding +
'begin' + LineEnding +
' C := TCat.Create;' + LineEnding +
' N := Use<TCat>(C);' + LineEnding +
' C.Free' + LineEnding +
'end.');
end;
procedure TGenericConstraintTests.TestSemantic_GenericFunc_NamedConstraint_Satisfied;
var Prog: TProgram;
begin
{ TPuppy inherits from TDog → OK }
Prog := AnalyseSrc(
'program P;' + LineEnding +
'type' + LineEnding +
' TDog = class(TObject) X: Integer; end;' + LineEnding +
' TPuppy = class(TDog) Y: Integer; end;' + LineEnding +
'function Use<T: TDog>(A: T): Integer;' + LineEnding +
'begin Result := 0 end;' + LineEnding +
'var P: TPuppy; N: Integer;' + LineEnding +
'begin' + LineEnding +
' P := TPuppy.Create;' + LineEnding +
' N := Use<TPuppy>(P);' + LineEnding +
' P.Free' + LineEnding +
'end.');
try AssertNotNull(Prog); finally Prog.Free; end;
end;
initialization
RegisterTest(TGenericConstraintTests);
end.

159
compiler/src/test/pascal/cp.test.multiwrite.pas Normal file
View file

@ -0,0 +1,159 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: BSD-3-Clause
See LICENSE file in the project root for full license terms.
}
unit cp.test.multiwrite;
{$mode objfpc}{$H+}
{ Tests for multi-argument Write and WriteLn code generation. }
interface
uses
Classes, SysUtils, StrUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TMultiWriteTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
function CountOccurrences(const AHaystack, ANeedle: string): Integer;
published
procedure TestCodegen_WriteLn_TwoArgs_EmitsTwoValuePrintfsPlusNewline;
procedure TestCodegen_WriteLn_ThreeArgs_EmitsTrailingNewline;
procedure TestCodegen_Write_TwoArgs_NoTrailingNewline;
procedure TestCodegen_WriteLn_MixedStringAndInteger;
procedure TestCodegen_WriteLn_Empty_StillEmitsNewline;
end;
implementation
function TMultiWriteTests.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 TMultiWriteTests.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 TMultiWriteTests.GenIR(const ASrc: string): string;
var Prog: TProgram; CG: TCodeGenQBE;
begin
Prog := AnalyseSrc(ASrc);
try
CG := TCodeGenQBE.Create;
try CG.Generate(Prog); Result := CG.GetOutput; finally CG.Free; end;
finally Prog.Free; end;
end;
function TMultiWriteTests.CountOccurrences(
const AHaystack, ANeedle: string): Integer;
var Pos, I: Integer;
begin
Result := 0;
I := 1;
repeat
Pos := PosEx(ANeedle, AHaystack, I);
if Pos = 0 then Break;
Inc(Result);
I := Pos + Length(ANeedle);
until False;
end;
procedure TMultiWriteTests.TestCodegen_WriteLn_TwoArgs_EmitsTwoValuePrintfsPlusNewline;
var
IR: string;
TotalPrintf, NewlinePrintf: Integer;
begin
IR := GenIR(
'program P;' + LineEnding +
'var I, J: Integer;' + LineEnding +
'begin' + LineEnding +
' I := 1; J := 2;' + LineEnding +
' WriteLn(I, J)' + LineEnding +
'end.');
TotalPrintf := CountOccurrences(IR, 'call $printf');
NewlinePrintf := CountOccurrences(IR, 'call $printf(l $__fmt_nl)');
AssertEquals('3 printf calls: 2 values + 1 newline', 3, TotalPrintf);
AssertEquals('1 newline printf', 1, NewlinePrintf);
end;
procedure TMultiWriteTests.TestCodegen_WriteLn_ThreeArgs_EmitsTrailingNewline;
var IR: string;
begin
IR := GenIR(
'program P;' + LineEnding +
'var A, B, C: Integer;' + LineEnding +
'begin' + LineEnding +
' A := 1; B := 2; C := 3;' + LineEnding +
' WriteLn(A, B, C)' + LineEnding +
'end.');
AssertTrue('emits newline call', Pos('call $printf(l $__fmt_nl)', IR) > 0);
AssertEquals('3 value + 1 newline = 4 printf calls',
4, CountOccurrences(IR, 'call $printf'));
end;
procedure TMultiWriteTests.TestCodegen_Write_TwoArgs_NoTrailingNewline;
var IR: string;
begin
IR := GenIR(
'program P;' + LineEnding +
'var I, J: Integer;' + LineEnding +
'begin' + LineEnding +
' I := 1; J := 2;' + LineEnding +
' Write(I, J)' + LineEnding +
'end.');
{ Write must not issue a trailing newline call. The format string is
always defined in the data section, so we look specifically for the
call (not the declaration). }
AssertEquals('no newline printf call', 0,
CountOccurrences(IR, 'call $printf(l $__fmt_nl)'));
AssertEquals('2 value printf calls', 2,
CountOccurrences(IR, 'call $printf'));
end;
procedure TMultiWriteTests.TestCodegen_WriteLn_MixedStringAndInteger;
var IR: string;
begin
IR := GenIR(
'program P;' + LineEnding +
'var I: Integer; S: string;' + LineEnding +
'begin' + LineEnding +
' I := 7;' + LineEnding +
' S := ''hi'';' + LineEnding +
' WriteLn(S, I)' + LineEnding +
'end.');
AssertTrue('uses string format call', Pos('$__fmt_s, ..., l ', IR) > 0);
AssertTrue('uses int format call', Pos('$__fmt_d, ..., w ', IR) > 0);
end;
procedure TMultiWriteTests.TestCodegen_WriteLn_Empty_StillEmitsNewline;
var IR: string;
begin
IR := GenIR(
'program P;' + LineEnding +
'begin' + LineEnding +
' WriteLn' + LineEnding +
'end.');
AssertTrue('empty WriteLn still emits newline',
Pos('call $printf(l $__fmt_nl)', IR) > 0);
end;
initialization
RegisterTest(TMultiWriteTests);
end.