Add semantic analyser with type inference and checking

TSemanticAnalyser walks the AST, resolves all identifiers via the symbol
table, annotates every expression node with ResolvedType, and type-checks
assignments and procedure calls. Raises ESemanticError with source position
on undeclared identifiers, type mismatches, duplicate declarations, and
unknown types. TProgram now owns the TSymbolTable after analysis so
ResolvedType pointers remain valid for the lifetime of the AST.

Also adds the 'div' keyword for integer division throughout the pipeline
(lexer, parser, semantic). 26 new FPCUnit tests, 126 total, all passing.
This commit is contained in:
Graeme Geldenhuys 2026-04-20 17:58:27 +01:00
parent a561525ebd
commit 4fbfdfdbba
6 changed files with 646 additions and 10 deletions

View file

@ -5,7 +5,7 @@ unit uAST;
interface
uses
Classes, SysUtils, contnrs;
Classes, SysUtils, contnrs, uSymbolTable;
type
{ Base node — all AST nodes carry source position. }
@ -19,7 +19,11 @@ type
{ Expressions }
{ ------------------------------------------------------------------ }
TASTExpr = class(TASTNode);
{ Semantic analyser fills ResolvedType on every expression node. }
TASTExpr = class(TASTNode)
public
ResolvedType: TTypeDesc; { set by uSemantic; nil until analysed }
end;
TIntLiteral = class(TASTExpr)
public
@ -73,8 +77,9 @@ type
TVarDecl = class(TASTNode)
public
Names: TStringList; { owned — one or more names: x, y: Integer }
TypeName: string;
Names: TStringList; { owned — one or more names: x, y: Integer }
TypeName: string;
ResolvedType: TTypeDesc; { set by uSemantic; nil until analysed }
constructor Create;
destructor Destroy; override;
end;
@ -93,15 +98,30 @@ type
TProgram = class(TASTNode)
public
Name: string;
UsedUnits: TStringList; { owned — unit names from uses clause }
Block: TBlock; { owned }
Name: string;
UsedUnits: TStringList; { owned — unit names from uses clause }
Block: TBlock; { owned }
SymbolTable: TSymbolTable; { owned after semantic analysis; nil before }
constructor Create;
destructor Destroy; override;
end;
function BinaryOpName(AOp: TBinaryOp): string;
implementation
function BinaryOpName(AOp: TBinaryOp): string;
begin
case AOp of
boAdd: Result := '+';
boSub: Result := '-';
boMul: Result := '*';
boDiv: Result := 'div';
else
Result := '?';
end;
end;
{ TBinaryExpr }
destructor TBinaryExpr.Destroy;
@ -173,6 +193,7 @@ end;
destructor TProgram.Destroy;
begin
SymbolTable.Free;
UsedUnits.Free;
Block.Free;
inherited Destroy;

View file

@ -29,7 +29,8 @@ type
tkPlus,
tkMinus,
tkStar,
tkSlash,
tkSlash, { '/' — future: float division }
tkDiv, { 'div' keyword — integer division }
{ Assignment and colon }
tkAssign, { := }
tkColon, { : }
@ -81,6 +82,7 @@ begin
else if AUpper = 'VAR' then Result := tkVar
else if AUpper = 'BEGIN' then Result := tkBegin
else if AUpper = 'END' then Result := tkEnd
else if AUpper = 'DIV' then Result := tkDiv
else
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
end;

View file

@ -313,7 +313,7 @@ var
Node: TBinaryExpr;
begin
Result := ParseFactor;
while Check(tkStar) or Check(tkSlash) do
while Check(tkStar) or Check(tkSlash) or Check(tkDiv) do
begin
if Check(tkStar) then Op := boMul else Op := boDiv;
Advance;

View file

@ -0,0 +1,233 @@
unit uSemantic;
{$mode objfpc}{$H+}
// Semantic analysis pass walks the AST produced by uParser and:
// 1. Resolves every identifier to a TSymbol in the symbol table.
// 2. Infers and annotates every expression node with ResolvedType.
// 3. Type-checks assignments (lhs type == rhs type).
// 4. Validates procedure/function calls (callee exists, arg types valid).
// 5. Raises ESemanticError with source position on any violation.
interface
uses
SysUtils, uAST, uSymbolTable;
type
ESemanticError = class(Exception);
TSemanticAnalyser = class
private
FTable: TSymbolTable;
procedure AnalyseBlock(ABlock: TBlock);
procedure AnalyseVarDecls(ABlock: TBlock);
procedure AnalyseStmts(ABlock: TBlock);
procedure AnalyseStmt(AStmt: TASTStmt);
procedure AnalyseAssignment(AAssign: TAssignment);
procedure AnalyseProcCall(ACall: TProcCall);
function AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
procedure SemanticError(const AMsg: string; ALine, ACol: Integer);
procedure CheckTypesMatch(AExpected, AActual: TTypeDesc;
const AContext: string; ALine, ACol: Integer);
public
constructor Create;
destructor Destroy; override;
procedure Analyse(AProg: TProgram);
end;
implementation
constructor TSemanticAnalyser.Create;
begin
inherited Create;
FTable := TSymbolTable.Create;
end;
destructor TSemanticAnalyser.Destroy;
begin
FTable.Free;
inherited Destroy;
end;
procedure TSemanticAnalyser.SemanticError(const AMsg: string; ALine, ACol: Integer);
begin
raise ESemanticError.CreateFmt('%s at line %d col %d', [AMsg, ALine, ACol]);
end;
procedure TSemanticAnalyser.CheckTypesMatch(AExpected, AActual: TTypeDesc;
const AContext: string; ALine, ACol: Integer);
begin
if AExpected <> AActual then
SemanticError(
Format('Type mismatch in %s: expected ''%s'' but got ''%s''',
[AContext, AExpected.Name, AActual.Name]),
ALine, ACol);
end;
procedure TSemanticAnalyser.Analyse(AProg: TProgram);
begin
AnalyseBlock(AProg.Block);
{ Transfer symbol table ownership to the program so that TTypeDesc
objects (referenced by ResolvedType pointers on AST nodes) outlive
this analyser. }
AProg.SymbolTable := FTable;
FTable := nil;
end;
procedure TSemanticAnalyser.AnalyseBlock(ABlock: TBlock);
begin
FTable.PushScope;
try
AnalyseVarDecls(ABlock);
AnalyseStmts(ABlock);
finally
FTable.PopScope;
end;
end;
procedure TSemanticAnalyser.AnalyseVarDecls(ABlock: TBlock);
var
I, J: Integer;
Decl: TVarDecl;
Typ: TTypeDesc;
VarName: string;
Sym: TSymbol;
begin
for I := 0 to ABlock.Decls.Count - 1 do
begin
Decl := TVarDecl(ABlock.Decls[I]);
Typ := FTable.FindType(Decl.TypeName);
if Typ = nil then
SemanticError(
Format('Unknown type ''%s''', [Decl.TypeName]),
Decl.Line, Decl.Col);
Decl.ResolvedType := Typ;
for J := 0 to Decl.Names.Count - 1 do
begin
VarName := Decl.Names[J];
Sym := TSymbol.Create(VarName, skVariable, Typ);
if not FTable.Define(Sym) then
begin
Sym.Free;
SemanticError(
Format('Duplicate identifier ''%s''', [VarName]),
Decl.Line, Decl.Col);
end;
end;
end;
end;
procedure TSemanticAnalyser.AnalyseStmts(ABlock: TBlock);
var
I: Integer;
begin
for I := 0 to ABlock.Stmts.Count - 1 do
AnalyseStmt(TASTStmt(ABlock.Stmts[I]));
end;
procedure TSemanticAnalyser.AnalyseStmt(AStmt: TASTStmt);
begin
if AStmt is TAssignment then
AnalyseAssignment(TAssignment(AStmt))
else if AStmt is TProcCall then
AnalyseProcCall(TProcCall(AStmt));
end;
procedure TSemanticAnalyser.AnalyseAssignment(AAssign: TAssignment);
var
VarSym: TSymbol;
ExprType: TTypeDesc;
begin
VarSym := FTable.Lookup(AAssign.Name);
if VarSym = nil then
SemanticError(
Format('Undeclared variable ''%s''', [AAssign.Name]),
AAssign.Line, AAssign.Col);
if VarSym.Kind <> skVariable then
SemanticError(
Format('''%s'' is not a variable', [AAssign.Name]),
AAssign.Line, AAssign.Col);
ExprType := AnalyseExpr(AAssign.Expr);
CheckTypesMatch(VarSym.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col);
end;
procedure TSemanticAnalyser.AnalyseProcCall(ACall: TProcCall);
var
Sym: TSymbol;
I: Integer;
begin
Sym := FTable.Lookup(ACall.Name);
if Sym = nil then
SemanticError(
Format('Undeclared procedure ''%s''', [ACall.Name]),
ACall.Line, ACall.Col);
if not (Sym.Kind in [skProcedure, skFunction]) then
SemanticError(
Format('''%s'' is not a procedure or function', [ACall.Name]),
ACall.Line, ACall.Col);
{ Analyse argument expressions for type correctness.
Phase 1 built-ins (Write/WriteLn) accept any single argument
detailed overload resolution is a Phase 2 enhancement. }
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args[I]));
end;
function TSemanticAnalyser.AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
var
Sym: TSymbol;
begin
if AExpr is TIntLiteral then
Result := FTable.TypeInteger
else if AExpr is TStringLiteral then
Result := FTable.TypeString
else if AExpr is TIdentExpr then
begin
Sym := FTable.Lookup(TIdentExpr(AExpr).Name);
if Sym = nil then
SemanticError(
Format('Undeclared identifier ''%s''', [TIdentExpr(AExpr).Name]),
AExpr.Line, AExpr.Col);
Result := Sym.TypeDesc;
end
else if AExpr is TBinaryExpr then
Result := AnalyseBinaryExpr(TBinaryExpr(AExpr))
else
SemanticError('Unknown expression node', AExpr.Line, AExpr.Col);
AExpr.ResolvedType := Result;
end;
function TSemanticAnalyser.AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
var
LType, RType: TTypeDesc;
begin
LType := AnalyseExpr(ABin.Left);
RType := AnalyseExpr(ABin.Right);
{ Arithmetic operators require both operands to be numeric. }
if not LType.IsNumeric then
SemanticError(
Format('Left operand of ''%s'' must be numeric, got ''%s''',
[BinaryOpName(ABin.Op), LType.Name]),
ABin.Line, ABin.Col);
if not RType.IsNumeric then
SemanticError(
Format('Right operand of ''%s'' must be numeric, got ''%s''',
[BinaryOpName(ABin.Op), RType.Name]),
ABin.Line, ABin.Col);
CheckTypesMatch(LType, RType, 'binary expression', ABin.Line, ABin.Col);
Result := LType;
end;
end.

View file

@ -13,7 +13,8 @@ uses
cp.test.lexer,
cp.test.parser,
cp.test.codegen,
cp.test.symtable;
cp.test.symtable,
cp.test.semantic;
var
Application: TTestRunner;

View file

@ -0,0 +1,379 @@
unit cp.test.semantic;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic;
type
TSemanticTests = class(TTestCase)
private
function Analyse(const ASrc: string): TProgram;
procedure AnalyseExpectError(const ASrc: string);
published
{ Variable declarations are added to the symbol table }
procedure TestVarDecl_RegistersSymbol;
procedure TestVarDecl_Type_Integer;
procedure TestVarDecl_Type_String;
procedure TestVarDecl_MultiName_BothRegistered;
procedure TestVarDecl_UnknownType_RaisesError;
procedure TestVarDecl_Duplicate_RaisesError;
{ Expression type inference }
procedure TestExpr_IntLiteral_TypeIsInteger;
procedure TestExpr_StringLiteral_TypeIsString;
procedure TestExpr_Ident_ResolvesToVarType;
procedure TestExpr_Ident_Undeclared_RaisesError;
procedure TestExpr_Add_TwoIntegers_TypeIsInteger;
procedure TestExpr_Add_IntAndString_RaisesError;
procedure TestExpr_Sub_TypeIsInteger;
procedure TestExpr_Mul_TypeIsInteger;
procedure TestExpr_Div_TypeIsInteger;
{ Assignment type checking }
procedure TestAssign_IntToInt_OK;
procedure TestAssign_StringToString_OK;
procedure TestAssign_IntToString_RaisesError;
procedure TestAssign_StringToInt_RaisesError;
procedure TestAssign_UndeclaredVar_RaisesError;
{ Procedure calls }
procedure TestProcCall_WriteLn_NoArgs_OK;
procedure TestProcCall_WriteLn_StringArg_OK;
procedure TestProcCall_WriteLn_IntArg_OK;
procedure TestProcCall_UndeclaredProc_RaisesError;
{ Full program analysis }
procedure TestProgram_HelloWorld_OK;
procedure TestProgram_ArithmeticAndPrint_OK;
end;
implementation
function TSemanticTests.Analyse(const ASrc: string): TProgram;
var
L: TLexer;
P: TParser;
A: TSemanticAnalyser;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Result := P.Parse;
finally
P.Free;
L.Free;
end;
A := TSemanticAnalyser.Create;
try
A.Analyse(Result);
finally
A.Free;
end;
end;
procedure TSemanticTests.AnalyseExpectError(const ASrc: string);
var
Prog: TProgram;
begin
try
Prog := Analyse(ASrc);
Prog.Free;
Fail('Expected ESemanticError');
except
on E: ESemanticError do ; { expected }
end;
end;
{ ------------------------------------------------------------------ }
{ Var declarations }
{ ------------------------------------------------------------------ }
procedure TSemanticTests.TestVarDecl_RegistersSymbol;
var
Prog: TProgram;
Decl: TVarDecl;
begin
Prog := Analyse('program P; var x: Integer; begin end.');
try
AssertEquals('1 decl', 1, Prog.Block.Decls.Count);
Decl := TVarDecl(Prog.Block.Decls[0]);
AssertNotNull('ResolvedType set', Decl.ResolvedType);
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestVarDecl_Type_Integer;
var
Prog: TProgram;
begin
Prog := Analyse('program P; var n: Integer; begin end.');
try
AssertEquals('Integer kind',
Ord(tyInteger),
Ord(TVarDecl(Prog.Block.Decls[0]).ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestVarDecl_Type_String;
var
Prog: TProgram;
begin
Prog := Analyse('program P; var s: string; begin end.');
try
AssertEquals('string kind',
Ord(tyString),
Ord(TVarDecl(Prog.Block.Decls[0]).ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestVarDecl_MultiName_BothRegistered;
var
Prog: TProgram;
Decl: TVarDecl;
begin
Prog := Analyse('program P; var x, y: Integer; begin end.');
try
Decl := TVarDecl(Prog.Block.Decls[0]);
AssertNotNull('ResolvedType', Decl.ResolvedType);
AssertEquals('Integer', Ord(tyInteger), Ord(Decl.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestVarDecl_UnknownType_RaisesError;
begin
AnalyseExpectError('program P; var x: Foobar; begin end.');
end;
procedure TSemanticTests.TestVarDecl_Duplicate_RaisesError;
begin
AnalyseExpectError(
'program P; var x: Integer; x: string; begin end.');
end;
{ ------------------------------------------------------------------ }
{ Expression type inference }
{ ------------------------------------------------------------------ }
procedure TSemanticTests.TestExpr_IntLiteral_TypeIsInteger;
var
Prog: TProgram;
Assign: TAssignment;
begin
Prog := Analyse('program P; var n: Integer; begin n := 42 end.');
try
Assign := TAssignment(Prog.Block.Stmts[0]);
AssertNotNull('Expr type', Assign.Expr.ResolvedType);
AssertEquals('Integer',
Ord(tyInteger), Ord(Assign.Expr.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestExpr_StringLiteral_TypeIsString;
var
Prog: TProgram;
Assign: TAssignment;
begin
Prog := Analyse(
'program P; var s: string; begin s := ''hello'' end.');
try
Assign := TAssignment(Prog.Block.Stmts[0]);
AssertEquals('string',
Ord(tyString), Ord(Assign.Expr.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestExpr_Ident_ResolvesToVarType;
var
Prog: TProgram;
Bin: TBinaryExpr;
begin
Prog := Analyse(
'program P; var x, y: Integer; begin y := x + 1 end.');
try
Bin := TBinaryExpr(TAssignment(Prog.Block.Stmts[0]).Expr);
AssertNotNull('Left type', Bin.Left.ResolvedType);
AssertEquals('x is Integer',
Ord(tyInteger), Ord(Bin.Left.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestExpr_Ident_Undeclared_RaisesError;
begin
AnalyseExpectError(
'program P; var n: Integer; begin n := undeclared end.');
end;
procedure TSemanticTests.TestExpr_Add_TwoIntegers_TypeIsInteger;
var
Prog: TProgram;
Bin: TBinaryExpr;
begin
Prog := Analyse(
'program P; var n: Integer; begin n := 1 + 2 end.');
try
Bin := TBinaryExpr(TAssignment(Prog.Block.Stmts[0]).Expr);
AssertEquals('Add result is Integer',
Ord(tyInteger), Ord(Bin.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestExpr_Add_IntAndString_RaisesError;
begin
AnalyseExpectError(
'program P; var n: Integer; s: string; begin n := n + s end.');
end;
procedure TSemanticTests.TestExpr_Sub_TypeIsInteger;
var
Prog: TProgram;
Bin: TBinaryExpr;
begin
Prog := Analyse(
'program P; var n: Integer; begin n := 10 - 3 end.');
try
Bin := TBinaryExpr(TAssignment(Prog.Block.Stmts[0]).Expr);
AssertEquals('Sub is Integer',
Ord(tyInteger), Ord(Bin.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestExpr_Mul_TypeIsInteger;
var
Prog: TProgram;
Bin: TBinaryExpr;
begin
Prog := Analyse(
'program P; var n: Integer; begin n := 3 * 4 end.');
try
Bin := TBinaryExpr(TAssignment(Prog.Block.Stmts[0]).Expr);
AssertEquals('Mul is Integer',
Ord(tyInteger), Ord(Bin.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TSemanticTests.TestExpr_Div_TypeIsInteger;
var
Prog: TProgram;
Bin: TBinaryExpr;
begin
Prog := Analyse(
'program P; var n: Integer; begin n := 8 div 2 end.');
try
Bin := TBinaryExpr(TAssignment(Prog.Block.Stmts[0]).Expr);
AssertEquals('Div is Integer',
Ord(tyInteger), Ord(Bin.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Assignment type checking }
{ ------------------------------------------------------------------ }
procedure TSemanticTests.TestAssign_IntToInt_OK;
begin
Analyse('program P; var n: Integer; begin n := 5 end.').Free;
end;
procedure TSemanticTests.TestAssign_StringToString_OK;
begin
Analyse(
'program P; var s: string; begin s := ''hi'' end.').Free;
end;
procedure TSemanticTests.TestAssign_IntToString_RaisesError;
begin
AnalyseExpectError(
'program P; var s: string; begin s := 42 end.');
end;
procedure TSemanticTests.TestAssign_StringToInt_RaisesError;
begin
AnalyseExpectError(
'program P; var n: Integer; begin n := ''hello'' end.');
end;
procedure TSemanticTests.TestAssign_UndeclaredVar_RaisesError;
begin
AnalyseExpectError(
'program P; begin ghost := 1 end.');
end;
{ ------------------------------------------------------------------ }
{ Procedure calls }
{ ------------------------------------------------------------------ }
procedure TSemanticTests.TestProcCall_WriteLn_NoArgs_OK;
begin
Analyse('program P; begin WriteLn end.').Free;
end;
procedure TSemanticTests.TestProcCall_WriteLn_StringArg_OK;
begin
Analyse('program P; begin WriteLn(''Hello'') end.').Free;
end;
procedure TSemanticTests.TestProcCall_WriteLn_IntArg_OK;
begin
Analyse('program P; begin WriteLn(99) end.').Free;
end;
procedure TSemanticTests.TestProcCall_UndeclaredProc_RaisesError;
begin
AnalyseExpectError('program P; begin NoSuchProc end.');
end;
{ ------------------------------------------------------------------ }
{ Full programs }
{ ------------------------------------------------------------------ }
procedure TSemanticTests.TestProgram_HelloWorld_OK;
begin
Analyse(
'program Hello;' + LineEnding +
'begin' + LineEnding +
' WriteLn(''Hello!'');' + LineEnding +
'end.'
).Free;
end;
procedure TSemanticTests.TestProgram_ArithmeticAndPrint_OK;
begin
Analyse(
'program Arith;' + LineEnding +
'var n: Integer;' + LineEnding +
'begin' + LineEnding +
' n := 3 * 4 + 2;' + LineEnding +
' WriteLn(n);' + LineEnding +
'end.'
).Free;
end;
initialization
RegisterTest(TSemanticTests);
end.