From 4fbfdfdbbad26d1d7f0d513f1a80a69b8fd027b7 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 20 Apr 2026 17:58:27 +0100 Subject: [PATCH] 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. --- compiler/src/main/pascal/uAST.pas | 35 +- compiler/src/main/pascal/uLexer.pas | 4 +- compiler/src/main/pascal/uParser.pas | 2 +- compiler/src/main/pascal/uSemantic.pas | 233 +++++++++++ compiler/src/test/pascal/TestRunner.pas | 3 +- compiler/src/test/pascal/cp.test.semantic.pas | 379 ++++++++++++++++++ 6 files changed, 646 insertions(+), 10 deletions(-) create mode 100644 compiler/src/main/pascal/uSemantic.pas create mode 100644 compiler/src/test/pascal/cp.test.semantic.pas diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index a4eaa81..613ab59 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index 488e068..366f6e3 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -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; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index bde728f..771f4c3 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas new file mode 100644 index 0000000..dd74507 --- /dev/null +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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. diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 1fe035d..1a24b27 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.semantic.pas b/compiler/src/test/pascal/cp.test.semantic.pas new file mode 100644 index 0000000..49da9a6 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.semantic.pas @@ -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.